1  •  j 


A111DD  TflMSflT 


auto  mm 


UNITED  STATES  DEPARTMENT  OF  COMMERCE  •  Maurice  H.  Stans,  Secretary 
NATIONAL  BUREAU  OF  STANDARDS  •  Lewis  M.  Branscomb,  Director 


Source  Listing  of  OMNITAB  II  Program 


Sally  T.  Peavy,  Ruth  N.  Varner,  and  David  Hogben 


Statistical  Engineering  Laboratory 
Applied  Mathematics  Division 
Institute  for  Basic  Standards 
National  Bureau  of  Standards 
Washington,  D.C.  20234 


>  •  » 


Nat.  Bur.  Stand.  (U.S.),  Spec.  Publ.  339,  371  pages  (Dec.  1970) 


CODEN:  XNBSA 


Issued  December  1970 


For  sale  by  the  Superintendent  of  Documents,  U.S.  Government  Printing  Office,  Washington,  D.C.  20402  (Order  by  SD  Catalog  No.  C  13.10:339),  Price  $4.75 


NATIONAL  BUREAU  OF  STANDARDS 
APR      &  1971 

180322 

Q  CIOO 
.U  51 


Library  of  Congress  Catalog  Card  Number:  79-609406 


Contents 


Page 

Introduction   1 

Description   1 

Programming  Techniques   2 

OMNITAB  II  Operating  System  Routines   3 

References   4 

Table  of  Contents  for  Subprogram  Listings   5 

Listing  of  Subprograms   7 

Appendix-OMNIT  Flow  Chart   346 


III 


Source  Listing  of  OMNITAB  II  Program 


Sally  T.  Peavy,  Ruth  N.  Varner,  and  David  Hogben 

OMNITAB  II  is  a  general-purpose  interpretive  computing  system  designed  to  allow  a  nonprogram- 
mer  to  use  a  high-speed  computer  easily,  accurately  and  effectively.  The  system  permits  the  user  to 
perform  arithmetic  operations  including  complex  arithmetic,  trigonometric  calculations,  miscellaneous 
function  calculations,  statistical  analysis,  Bessel  function  calculations,  and  operations  on  matrices  and 
arrays. 

The  OMNITAB  II  system  contains  177  subprograms  written  in  the  ANSI  FORTRAN  language. 
Every  effort  has  been  made  to  make  the  system  transportable.  This  publication  contains  a  complete 
listing  of  all  these  subprograms.  The  listing  is  preceded  by  a  brief  introduction  which  describes  the 
programming  techniques  used;  the  use  of  system  library  functions;  and  the  subprograms  used  to  con- 
trol the  flow  of  operations  in  the  OMNITAB  system. 

Key  words:  Accuracy;  algorithms;  ANSI  FORTRAN;  documentation;  error  checking;  machine  in- 
dependent; OMNITAB  II  operating  system  subprograms;  OMNITAB  II  source  listing;  programming 
techniques;  transportable;  user-oriented  computing  system. 


1.  Introduction 

The  OMNITAB  II  computing  system  enables 
the  nonprogrammer  to  use  a  large  digital  computer 
to  perform  data,  statistical,  and  numerical  analysis 
without  having  any  prior  knowledge  of  computers 
or  computer  languages.  The  user  writes  simple 
English  instructions  to  obtain  accurate  results 
easily  and  effectively.  The  instructions  reference 
reliable,  varied,  and  sophisticated  algorithms  for 
analysis  and  manipulation.  The  tedious  task  of 
formatting  data  for  input  and  output  is  alleviated 
by  OMNITAB  II  through  free  field  input,  readable 
printing,  and  automatic  printouts.  Formatting  capa- 
bility exists,  if  more  flexibility  is  desired.  The 
system  permits  the  user  to  perform:  arithmetic 
operations  including  complex  arithmetic,  trigono- 
metric calculations,  data  manipulations,  mis- 
cellaneous function  calculations,  statistical  analysis, 
numerical  analysis,  Bessel  function  calculations, 
operations  on  matrices  and  arrays,  and  thermo- 
dynamic calculations.  Although  OMNITAB  has 
been  specifically  designed  for  nonprogrammers, 
many  experienced  programmers  find  uses  for 
OMNITAB. 

OMNITAB  was  developed  at  the  National  Bureau 
of  Standards  under  the  guidance  of  Joseph  Hil- 
senrath  who  contributed  the  basic  ideas  and 
philosophy,  see  Hilsenrath  et  al.  [1966].  The  program 
was  written  initially  in  a  mixture  of  symbolic 
machine  language  and  FORTRAN.  With  the  advent 
of  third  generation  computers  and  the  success  of 
OMNITAB,  it  became  necessary  to  rewrite  the 
program  and  to  make  it  as  machine  independent 
as  possible.  Walter  J.  Gilbert  undertook  this  task 
in  1966  and  initiated  a  number  of  changes  and  new 
features.  Since  1968,  the  Statistical  Engineering 
Laboratory,  Applied  Mathematics  Division,  has 
been  responsible  for  the  development,  maintenance, 
and  management  of  OMNITAB.  NBS  OMNITAB  II 
Version  5.0  (Hogben  et  al.  [1970])  is  the  result 
of  this  effort. 


2.  Description 

This  publication  is  one  of  four  which  constitute 
the  documentation  for  OMNITAB  II.  A  user's 
guide  is  given  in  Hogben  et  al.  [1970].  A  systems 
programmer's  guide  is  contained  in  Peavy  et  al. 
[1970].  Problems  and  results  for  assessing  the  suc- 
cess of  implementing  OMNITAB  II  are  given  in 
Varner  et  al.  [1970].  No  attempt  is  made  to  make 
this  publication  independent  of  the  other  three. 
In  particular,  the  reader  should  consult  Hogben 
et  al.  [1970]  for  a  general  understanding  of  OMNITAB 
II  and  for  an  explanation  of  terms  used  in  conjunc- 
tion with  OMNITAB  II. 

The  OMNITAB  II  software  system  contains  177 
subprograms  written  in  American  National  Standard 
(ANSI)  FORTRAN  language.  This  publication  con- 
tains a  listing  of  all  of  these  subprograms  in  section 
7.  The  subprograms  are  listed  alphabetically  by  the 
subprogram  name;  except  for  the  main  program 
which  appears  first.  Each  subprogram  has  a  unique 
identification  in  columns  73-75.  Sequential  line 
numbers  appear  in  columns  76-79.  This  provides 
a  means  of  easily  updating  the  subprogram  when 
improvements  are  made.  Each  subprogram  has 
been  tidied  using  the  program  of  Murphy  [1966]. 

A  table  of  contents  giving  the  subprogram  name, 
subprogram  identification,  and  page  number  is 
given  in  section  6  on  pages  5  and  6.  Along  with  the 
identification,  symbols  are  used  to  indicate  the  main 
function  of  each  subprogram.  The  symbol  denotes 
the  main  purpose  and  not  necessarily  the  sole 
function  of  the  subprogram.  For  example,  OMNIT  is 
an  executive  subprogram,  but  it  also  executes  the 
command  NOTE. 

The  material  contained  herein  is  a  complete 
listing  of  the  OMNITAB  II  program  with  some  ex- 
ceptions. Subprograms  which  compute  the  square 
root,  sin,  cos,  tan,  input  and  output  and  other  sub- 
programs which  are  normally  part  of  the  operating 
system  library  are  not  included;  see  Peavy  et  al. 
[1970]. 
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Each  subprogram  has  been  tested  as  thoroughly 
as  possible.  A  few  errors  which  escaped  detection 
in  the  preliminary  testing  were  subsequently 
detected  in  extensive  use  and  corrected.  Despite 
considerable  effort  to  make  OMNITAB  II  error 
free,  a  few  errors  are  to  be  expected  in  such  a  large 
system.  We  believe  that  any  errors  that  remain  are 
few  in  number.  Any  reader  who  finds  errors  or  has 
any  comments  is  encouraged  to  write  to  us  so  that 
improvements  can  be  passed  on  to  other  users. 


3.  Programming  Techniques 

The  subprograms  which  comprise  the  OMNITAB 
II  system  were  the  efforts  of  many  individuals  work- 
ing independently  with  considerable  latitude.  Thus, 
the  programming  techniques  used  in  the  sub- 
programs are  varied.  However,  each  subprogram 
had  to  satisfy  the  following  criteria. 

(a)  Programming  language.  All  subprograms  are 
written  in  the  ANSI  FORTRAN  language.  Thus, 
the  routines  which  scan  the  OMNITAB  II  instruc- 
tions, manipulate  and  pack  characters,  and  involve 
input-output  are  lengthy  and  to  a  limited  extent 
inefficient.  These  routines  could  be  written  in 
machine  language  for  a  particular  computer  instal- 
lation if  efficiency  were  sufficiently  important. 
However,  more  attention  has  been  devoted  to  de- 
veloping a  system  which  is  transportable  and  easily 
used.  Since  OMNITAB  II  is  designed  primarily 
for  the  analysis  of  small-to-moderate  amounts  of 
data,  these  considerations  are  far  more  important 
than  machine  efficiency  up  to  a  certain  point. 

Every  effort  was  made  to  produce  machine  in- 
dependent subprograms  in  order  to  make  the  entire 
system  transportable.  Where  it  was  necessary  to 
supply  alphanumeric  information,  a  maximum  of 
three  characters  per  machine  word  was  permitted. 
The  only  exception  is  in  the  case  where  user  defined 
formats  are  packed  to  a  full  capacity  of  the  machine 
word.  Formats  containing  information  for  printout 
were  restricted  to  120  characters  per  line.  Variable 
names  were  used  in  all  references  to  input-output 
devices.  These  special  features  are  discussed 
further  in  Peavy  et  al.  [1970].  All  FORTRAN  com- 
pilers do  not  accept  every  ANSI  FORTRAN 
statement  and  efforts  were  made  to  avoid  the  use 
of  such  statements. 

(b)  Algorithms.  The  policy  is  to  use  the  most 
reliable  and  accurate  algorithms.  In  some  instances 
it  was  not  feasible  to  adhere  to  this  policy  completely. 
Sometimes,  a  good  algorithm  was  accepted  with 
the  intention  of  improving  it  at  a  later  date.  This  is 
particularly  true  for  the  commands  with  compre- 
hensive automatic  printing.  Again,  efficiency  was 
subordinated  to  accuracy  when  necessary.  Most 
calculations  are  performed  using  single  precision 
floating-point  arithmetic.  In  a  few  instances,  where 
more  accuracy  was  deemed  desirable,  double  pre- 
cision floating-point  arithmetic  was  used.  Double 


precision  arithmetic  was  used  primarily  to  obtain 
full  single  precision  accuracy. 

(c)  Error  checking.  Every  subprogram  which  exe- 
cutes a  command  is  required  to  do  extensive  error 
checking.  Besides  checking  for  correct  number  and 
type  of  arguments  and  previous  errors,  the  sub- 
programs have  to  perform  unique  checks  for  the 
particular  command  that  is  to  be  executed.  Specific 
messages  are  printed  and  execution  of  further 
OMNITAB  instructions  may  be  affected  depending 
upon  the  severity  of  the  error.  However,  this  does 
not  prevent  OMNlTAB  from  scanning  the  remain- 
ing instructions  for  errors  unless  the  instruction 
is  stored.  See  Hogben  et  al.  [1970]  and  Peavy  et  al. 
[1970]  for  further  details. 

(d)  Elementary  functions.  The  original  OMNITAB 
had  its  own  programs  to  compute  the  elementary 
functions  (SIN,  LOGE,  etc.)  which  were  of  known 
accuracy.  In  order  to  make  OMNITAB  II  as 
transportable  as  possible,  this  procedure  was  not 
followed  and  the  system  library  functions  of  the 
particular  computer  system  are  used.  The  accuracy 
of  system  library  subroutines  varies  from  one 
computer  to  another.  Some  are  quite  accurate; 
others  are  surprisingly  inaccurate  as  was  explained 
excellently  by  Cody  [1970]. 

Many  system  library  functions  terminate  execu- 
tion if  an  arithmetic  fault  is  encountered;  for 
example,  in  computing  the  square  root  of  a  negative 
number.  This  confuses  and  hinders  the  nonpro- 
grammer  since  the  messages  upon  termination  are 
cryptic  and  often  the  fault  is  not  significant.  Efforts 
have  been  made  to  eliminate  this  nuisance  in 
OMNITAB  II.  The  subprograms  are  not  permitted 
to  use  any  of  the  library  functions  directly.  Instead, 
they  reference  other  function  routines  which  check 
the  values  of  the  arguments  to  be  used  by  the 
system  library  functions.  See  Peavy  et  al.  [1970] 
for  a  list  of  these  function  routines.  Only  if  the  values 
are  arithmetically  legitimate  and  within  certain 
bounds  will  the  system  library  functions  be  used. 
Otherwise,  a  very  explicit  diagnostic  message  will 
be  printed.  The  result  is  set  equal  to  zero  and  ex- 
ecution is  continued. 

(e)  Input-output  routines.  Input-output  conver- 
sion routines  were  also  part  of  the  old  OMNITAB, 
but  again  these  had  to  be  dropped  in  favor  of  using 
operating  system  routines  to  make  OMNITAB  more 
transportable.  There  is  one  important  exception. 
The  subprogram  RFORMT  does  the  necessary 
output  conversion  for  many  of  the  basic  printing 
commands.  RFORMT  does  its  own  conversion  to 
enable  the  printing  of  numbers  in  a  more  readable 
form.  The  conversion  is  as  accurate  as  or  more 
accurate  than  the  standard  operating  system  output 
conversion  routines.  See  Hogben  [1970]  for  further 
details. 

(f)  Division  by  zero.  Computer  operating  systems 
handle  division  by  zero  in  many  different  ways. 
In  some  instances  a  run  may  be  terminated,  in 
other  cases  it  may  be  ignored,  and  sometimes  just 


2 


a  message  is  printed  that  division  by  zero  was  at- 
tempted. The  OMNITAB  II  commands  which 
specifically  call  for  division,  such  as  DIVIDE  and 
ADIVIDE,  provide  a  check  on  zero  before  division 
is  attempted.  If  the  divisor  is  zero,  the  result  is 
set  equal  to  zero,  a  message  is  printed,  and  execu- 
tion is  continued. 

In  some  commands  division  by  zero  can  occur 
in  nonobvious  places  depending  upon  the  algorithm 
which  is  used,  as  in  the  FIT  command.  When  it 
is  known  that  a  divisor  can  equal  zero,  a  check 
on  the  divisor  was  provided.  However,  a  check 
on  the  divisor  is  not  made  in  every  instance  that 
division  is  used.  It  is  possible  that  an  error  termina- 
tion could  occur,  but  it  is  not  likely. 

(g)  Comment  statements.  Comments  in  the  form 
of  FORTRAN  comment  statements  are  dispersed 
in  most  subprograms.  Some  of  the  comments  are 
very  detailed  and  complete  while  others  are  rather 
limited.  The  use  of  comments  was  at  the  discretion 
of  the  programmer  and  no  standard  style  or  format 
was  required.  Due  to  recent  changes  in  OMNITAB 
II,  some  of  the  comments  may  not  be  pertinent. 
No  effort  has  been  made  to  edit  the  comments. 

(h)  Stand  alone  subprograms.  Some  of  the  sub- 
programs may  be  used  separately  outside  the 
context  of  the  OMNITAB  II  system.  More  often, 
the  programmer  took  advantage  of  the  OMNITAB 
II  system  when  writing  a  particular  subprogram. 
A  list  of  all  the  stand  alone  programs  is  given  below. 
Some  use  the  OMNITAB  II  elementary  function 
routines  and  would  have  to  be  modified  accordingly. 
These  exceptions  are  shown  in  parentheses.  A 
number  of  other  subprograms,  not  listed  here,  such 
as  RFORMT  could  be  easily  modified  to  make  them 
stand  alone. 

ACCDIG  (FLOG10) 

computes   the   accuracy  of  one 
number  compared  to  another 
BEZERO  (FDSQRT) 

computes  zeros  of  Bessel  function 
of  order  zero 
BEZONE         computes  zeros  of  Bessel  func- 
tion of  order  one 
BJORCK  least   squares   quadratic   fit  for 

CORRELATION 
CBEI         (FDSIN,  FDCOS,  FDSQRT,  FDEXP) 
computes    Bessel    functions  of 
complex   argument,  with  and 
without  scale  factors 
DETRNK         computes  the  determinant  and 

rank  of  a  matrix 
FREQCY  (FLOG10) 

computes  the  frequency  distribu- 
tion of  a  column  of  numbers 
HDIAG  (FSQRT) 

computes  eigenvalues  and  eigen- 
vectors of  a  matrix 
INTRP  provides  n-point  Lagrangian  in- 

terpolation 


MXTXP  (calls    SORTSM    below)  per- 

forms matrix  multiplication 
X  'X  or  XX ' 

PVTRI  determines  if  matrix  is  upper  or 

lower  triangular 
RANKO  (equivalent  to  RANKX  below) 

RANKX  determines   ranks   of  a  set  of 

numbers 

RCSUM  computes  row  and  column  sums 

of  a  matrix 

RNJBK  machine  independent  pseudo  ran- 

dom number  generator 

SKSYMV  tests  for  skew  symmetry  of  a 

matrix 

SORTSM  sorts  products  of  matrix  multipli- 

cation and  sum 

SPINV  matrix  inversion  with  minimum 

round-off  error  accumulation 

SYMV  test  for  matrix  symmetry 


4.  OMNITAB    II    Operating  System 
Routines 

The  main  program  of  the  OMNITAB  II  system  is 
small  and  contains  one  call  to  the  OMNIT  subpro- 
gram. The  OMNIT  and  XECUTE  subprograms  are 
the  two  major  routines  in  the  OMNITAB  II  system. 
A  detailed  flow  chart  of  OMNIT,  prepared  using 
CAL-COMP  [1968],  is  given  in  the  appendix. 
A  capsule  summary  of  the  chief  function  of  each 
of  the  34  executive  subprograms  is  given  below. 
In  addition,  there  are  four  block  data  subprograms 
which  are  BLOCK,  LBCONS,  LOOKTB  and 
PHYSIC.  The  reader  can  consult  Peavy  et  al. 
[1970]  for  further  details. 


Main  Program 
AARGS 

ADRESS 

AERR 

ASTER 
CHKCOL 

CKIND 

ERROR 
EXPAND 


INFERR 
INPUT 
LOCATE 
LOOKUP 


calls  OMNIT 

converts  arguments  of  an  in- 
struction 

computes  memory  location  of 
first  row  of  worksheet  column 

tallys  and  prints  arithmetic 
faults 

checks  proper  use  of  asterisks 

checks  for  valid  column  num- 
bers and  computes  memory 
locations 

checks  mode  of  instruction  argu- 
ments 

prints  fatal  errors 

sets  up  IARGS,  ARGS  and 
KIND  for  use  of  arguments  by 
subprograms 

prints    informative  diagnostics 

reads  all  cards 

locates      stored  instructions 
assigns  values  to  Ll   and  L2 
which  are  used  by  XECUTE 


3 


MTXCHK  determines  if  matrix  fits  in  work- 

sheet and  computes  memory 
location 

NNAME  converts  command  name  to  a 

unique  number 

NONBLA  looks  for  next  non-blank  char- 

acter in  scanning  card 

OMCONV  converts  input  card  images  to 

standard  code 

OMNIT  main   subprogram   which  con- 

trols flow  of  operations 

OUTPUT  outputs  card  images  to  scratch 

unit 

PACK  packs  or  unpacks  alphanumeric 

characters 

PREPAK  controls    packing/unpacking  of 

characters  for  OMNITAB  II 
system 

READQ  converts  and  stores  data 

RNDOWN         prints  location  of  error  in  stored 

instructions 
SETQ  converts  and  stores  data 

SETUP  initializes   system  at  the  very 

beginning 

STMT  assembles   and  checks  an  in- 

struction number 

STORE  stores  numbered  instructions 

TAPOP  sets  up  arguments  for  tape  opera- 

tion commands 

VARCON  checks  for  legitimate  variables 

within  asterisk 

VECTOR  vectorizes  a  constant 

XECUTE  calls  appropriate  subprogram  to 

execute  an  instruction 

XOMNIT  initializing  for  OMNITAB  com- 

mand 

XPND  sets  up  IARGS,  ARGS  and  KIND 

for  stored  instructions 

XSTOP  terminates  use  of  OMNITAB  and 

returns  control  to  operating 
system 


OMNITAB  II  is  a  large  system  and  its  success  is 
due  in  no  small  part  to  the  fact  that  many  specialists 
have  contributed  to  its  development.  We  especially 
thank  J.  Hilsenrath  for  his  continued  interest  and 
advice.  Walter  J.  Gilbert  laid  the  foundation  for 
OMNITAB  II  by  developing  the  scan  routine,  many 
of  the  basic  subroutines,  and  by  adding  several  new 
features.  Joseph  M.  Cameron  formulated  the  set  of 
instructions  for  matrix  and  array  operations  in 
addition  to  providing  guidance,  particularly  in  the 
development  of  the  least  squares  curve  fitting  in- 
structions. The  following  individuals,  besides  the 


authors,  not  only  programmed  many  of  the  subpro- 
grams, but  checked  them  out  as  well:  Robert  C. 
McClenon,  Carla  G.  Messina,  Bradley  A.  Peavy, 
and  Philip  J.  Walsh.  M.  Stuart  Scott  did  a  fine  job 
of  developing  CORRELATION.  Irene  A.  Stegun 
and  Ruth  Zucker  provided  the  subroutine  ERRINT 
which  is  used  for  the  commands  ERROR  and  CERF; 
see  Stegun  and  Zucker  [1970].  Roy  H.  Wampler  and 
William  J.  Hall  provided  the  subroutine  BJORCK 
for  use  with  the  subprogram  CORREL.  We  thank 
John  Mandel  for  providing  an  approximation  to 
percentage  points  of  the  studentized  range,  which  is 
used  in  the  subprogram  ONEWAY.  Shirley  G. 
Bremer  gave  valuable  assistance  in  general  main- 
tenance and  housekeeping.  We  thank  Bruce  W. 
Ramsay  and  Robert  J.  Arms  of  the  Computer 
Services  Division  for  their  administrative  and  tech- 
nical support.  The  staff  of  the  Statistical  Engineering 
Laboratory,  under  Joan  R.  Rosenblatt,  made  inval- 
uable contributions  and  suggestions  arising  out  of 
their  varied  experiences  in  statistical  consulting. 
Carla  G.  Messina  merits  additional  thanks  for  pre- 
paring section  7  for  computerized  phototypesetting. 
Last,  but  not  least,  special  thanks  are  given  to  all 
the  users  who  made  valuable  comments  and 
stimulated  modifications  and  additions  to  the 
system. 
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6.  Table  of  Contents  for  Subprogram  Listings 


The  following  symbols  are  used  to  indicate  the  main  function  of  each  subprogram.  The  number  of  sub- 
programs in  each  category  is  given  in  parentheses  on  the  extreme  right. 


E  OMNITAB  II  executive  system  control  subprogram  (34) 

B  Block  data  executive  subprogram  (  4) 

F  Function  routine  as  defined  in  3  (d)  (14) 

I  executes  instruction(s)  (and  performs  calculations)  (77) 

C  performs  computations  for  subprogram(s)  which  execute  instruction(s)  (48) 


Subprogram  name 

Identification 

Page 

Subprogram  name 

Identification 

Page 

Main  Program 

OMS 

E 

7 

EXCHNG 

EXC 

I 

77 

AARGS 

AAR 

E 

8 

X"*1  a  r  TTl    A    TV  T  T\ 

EXPAND 

EXD 

E 

78 

ABRIDG 

ABR 

I 

10 

X~i  X  r  TTT»  /~i  y~v  TV  T 

EXPCON 

EXN 

I 

80 

ACCDIG 

ACC 

C 

11 

EXTREM 

EXT 

I 

82 

ADRESS 

ADR 

E 

11 

FCOS 

FCO 

F 

83 

AERR 

AER 

E 

12 

FDCOS 

FDC 

F 

83 

ALLSUB 

ALL 

I 

14 

FDEXP 

FDE 

F 

83 

APRINT 

APR 

I 

17 

FDLOG 

FDL 

F 

84 

ARITH 

ARI 

I 

20 

FDPCON 

FDP 

F 

84 

A    X~»  X  T  X  T  ~m — 1  s~^1 

ARYVEC 

ARY 

I 

22 

FDSIN 

FDS 

F 

84 

A  /™i  r  i  in  x-* 

ASTER 

AST 

E 

25 

x""^X~v  n  y  "v  xx  m 

FDSQRT 

FDQ 

F 

85 

BEGIN 

BEG 

I 

27 

FEXP 

FEX 

F 

85 

BEJN 

BEJ 

C 

28 

FEXP2 

FX2 

F 

85 

BESSEL 

BES 

I 

30 

FIXFLO 

FIX 

I 

86 

BEZERO 

BEZ 

c 

36 

FLIP 

FLI 

I 

87 

BEZONE 

BEO 

c 

37 

FLOG 

FLE 

F 

88 

BINTJO 

BIN 

c 

38 

FLOG10 

FLT 

F 

88 

BJORCK 

BJO 

c 

39 

FNEC 

FNE 

I 

89 

BLOCK 

BLO 

B 

41 

FNEIC 

FNC 

I 

90 

CBEI 

CBI 

C 

42 

FNKC 

FKC 

I 

91 

CBEK 

CBK 

c 

44 

FOURIA 

FOU 

C 

92 

CHANGE 

CHA 

I 

46 

FPPT 

FPP 

C 

93 

CHKCOL 

CHK 

E 

46 

FPROB 

FPR 

I 

94 

CKIND 

CKI 

E 

47 

FRDIST 

FRD 

I 

95 

CMPARA 

CMP 

C 

47 

FREQCY 

FRE 

C 

96 

CMSEPA 

CMS 

I 

48 

FSIN 

FSI 

F 

97 

COALES 

COA 

I 

51 

FSQRT 

FSQ 

F 

97 

COMELL 

COM 

C 

54 

FTANH 

FTA 

F 

97 

COMPLX 

COX 

I 

55 

FUNCT 

FUN 

I 

98 

CORREL 

COR 

I 

57 

GENER 

GEN 

I 

102 

Lor  UN  V 

CSP 

c 

62 

QUA 

I 

i  no 
103 

DBEJ 

DBE 

c 

64 

HDIAG 

HDI 

C 

104 

DEFINE 

DEF 

I 

66 

HEADS 

HEA 

C 

108 

DETRNK 

DET 

c 

67 

HISTGM 

HIS 

I 

110 

DHRND 

DHR 

c 

68 

IFS 

IFS 

I 

111 

DIMENS 

DIM 

I 

69 

INFERR 

INF 

E 

113 

DUMMYA 

DMA 

I 

70 

INPUT 

INP 

E 

116 

DUMMYB 

DMB 

I 

70 

INTERP 

INT 

I 

117 

DUMMYC 

DMC 

I 

70 

INTRP 

INR 

C 

119 

DUMMYD 

DMD 

I 

70 

INVCHK 

INK 

C 

121 

DUMMYE 

DME 

I 

70 

INVCOR 

INC 

C 

123 

DUMMYF 

DMF 

I 

70 

INVERT 

INV 

I 

125 

ERASE 

ERA 

I 

71 

ITERAT 

ITE 

I 

127 

ERRINT 

ERT 

c 

72 

LBCONS 

LBC 

B 

132 

ERROR 

ERR 

E 

74 

LIST 

LIS 

I 

133 
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6.  Table  of  Contents  for  Subprogram  Listings  (continued) 


Subprogram  name 

Identification 

Page 

Subprogram  name 

Identification 

Page 

T  OTATF 

LOC 

E 

1 33 
100 

PUNCH 

PUN 

I 

9^ 
zoo 

T  OOKTR 
i  j  v  7  v  /  rv  1 1  > 

LOT 

B 

1  34 

PVTRT 
i  V  l  rvl 

PVT 

C 

9^6 
zoo 

i  a  7  v  / 1\  u  r 

LOU 

E 

R  A  NKO 

RKO 

C 

9^7 

ZO  i 

MATRTX 

lV_L.il.  1  lll/V 

MAT 

I 

14^ 

RANKS 

H.-T1.1  1  l\kj 

RAS 

I 

9C18 

MDAMAn 
ivx  u  riivx  rv  i_/ 

MDA 

I 

140 

RAX 

C 

MFTCFN 

MEI 

I 

1  =il 

1\V^  o  U 1V1 

RCS 

C 

IVlio  \_*Z 

MIS 

I 

1  ^3 

lOO 

RF  ADO 

REQ 

E 

__-Ul 

MTST 

IVXiO  1 

MST 

C 

1  ^6 

RFADX 

REX 

I 

969 

1VXI\.XIV_/1 1 

MKR 

I 

1  ^8 

±00 

RFPTNC 

llllil  11  i  Vj 

T".  T» 

REP 

I 

964, 

MMTIT  T 

H  /fH  ITT  T 

MMU 

I 

160 

RFSFT 

RES 

I 

968 

MOP 

MOP 

I 

169 

lUL 

RFORMT 

111  \_/lll"l  1 

RFO 

/— i 

c 

96Q 

MOVF 

MOV 

I 

lfvl 

RNDOWN 

111  li/V/  Vr  1  1 

RND 

E 

973 

MPROP 

1V11  llV-Jl 

MPR 

1 

lOO 

RNTRK 

111  1 J  XJXY 

¥~»  ATT 

RNJ 

C 

973 

MR  ATSF 

IV  L  1  lil  1  O  JL_r 

MRA 

I 

1 73 

1  iO 

RPR  TNT 

111    IV 11 1  A 

RPR 

c 

274 

MSCROW 

MSC 

I 

]  lf\ 

X  1  \) 

SFI  FCT 

SEL 

I 

970 

1YTTRTAN 

1V1  1  lll-TVl  1 

MTR 

I 

1  7ft 

1  l  o 

SFT 

SET 

I 

989 
zoz 

MCK 

E 

181 

1  Ol 

SFTO 

OHj  1  V_/ 

STQ 

E 

983 

MXTX 
IVlyV  1  TV 

MXT 

I 

189 
io_ 

SFTUP 

JLi  1  Ul 

STP 

E 

984 

ZOt1 

MXTXP 

MXP 

C 

1  84 

SKSYMV 

kjJ\0  1  1V1  V 

SKS 

C 

98^ 

NNAMF 

1  i  1 X  .Tl.lVl.i_j 

NNA 

E 

SORDFR 

JV/111/1j  IX- 

SOD 

I 

986 

LOU 

NONRT  A 

1  i  V/liDl-A 

NON 

E 

1  86 
loo 

SORTSM 

OV^ll  1  oivi 

SOM 

C 

988 
zoo 

NOTFPR 

NOT 

I 

1  86 
loo 

SPATF 

OX  Avj  j__ 

SPA 

I 

980 

DANDVA 

VjAllV/  V  -TV 

OAN 

C 

1 87 

SPTNV 

Ol  111  V 

SPI 

c 

900 

OrOFFF 

OCO 

C 

1  8Q 

STATTS 

_ZJ  1  A  1  lj 

STA 

I 

909 

Z  7Z 

ornvAR 

V  /  V  *  V  7  V    1 1  \ 

OCV 

c 

1  Ql 

STMT 

O  X  ivx  X 

STM 

E 

300 

OMCONV 

V  7 1V1 V  ^  V  7 1  >  V 

OMC 

E 

1  Q9 

STORF 

O  X  \_/Xl.X_j 

STO 

E 

301 

OMNTT 

V7J.V11 1 1  1 

OMN 

E 

1 Q3 

O  X  V/XV1VX  X 

STT 

_— » 

C 

309 

OwZ 

ONFWAY 

ONE 

I 

1QQ 

1  77 

STRUVF 

kJ  X  XV  U  V  Xli 

STR 

c 

303 

V  7 .'.  V  7  ^  >  17 

0P0 

C 

906 

SYMV 

J  X  IVX  V 

SYM 

_— 1 

c 

303 

1  1 1 V7 

ORT 

I 

908 

ZvyO 

TAPOP 

X  -TV1  V_/X 

TAP 

E 

304 

(JUT 

ORTHRV 

v_7 1 V  1  1111  V 

ORV 

C 

99^ 

ZZO 

TAPOP9 

X  Al  v_7  l  Zj 

TP2 

I 

30S 

ORTPT  T 

ORP 

c 

997 

THFRMO 

X  XXI_jX\1VX\_/ 

THE 

I 

307 

\J  U  1  I   U  1 

OUT 

E 

930 
zoo 

X  X  v>4  X  X  X 

TPC 

c 

31  3 

PACK 

PAC 

E 

931 
zoi 

TR  ANSF 
x  xx_ri.ii  or 

TRA 

c 

314 

PAGF 

PAG 

I 

939 
zoz 

TWOWAY 

X  W  KJ  W  A  X 

TWO 

I 

316 

PDMOTF 

1  JL/1V1V-/  1  Hi 

PDM 

I 

933 
zoo 

VARCON 

V  _Ti.X\\_>iV_/l  1 

VAR 

E 

332 

X  11  X  \_jV_71  1 

PHY 

I 

93^ 
zoo 

VFTTOR 

V  J_j\_.  X  v/ 1 1 

VEC 

E 

339 

1   1 1  1  JIVj 

PHC 

B 

936 
zoo 

XFCTITF 

XEC 

E 

333 

PT  OT 

PLO 

I 

938 
zoo 

YFORMT 
jvr  v_/x\ivx  x 

XFO 

I 

341 

PRFPAK 

PRE 

E 

94=1 

XHF  AD 

XHE 

I 

341 

PRINTX 

PRI 

I 

248 

XOMNIT 

XOM 

E 

342 

PROB 

PRB 

C 

250 

XPND 

XPN 

E 

344 

PROCHK 

PRK 

C 

252 

XSTOP 

XST 

E 

345 

PROROW 

PRO 

I 

253 
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7.  Listing  of  Subprograms 


C         THIS  IS  THE  MAIN  PROGRAM  OF  OMNITAB                                                     OMS  10 

C         VERSION    5.00  OMNSYM         5/15/70                                                   OMS  20 

C  OMS  30 

CALL  OMNIT  OMS  40 

STOP  OMS  50 

END  OMS  60 
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SUBROUTINE  AARGS 

VERSION    5.00         AARGS  5/15/70 

COMMON  /BLOCKA/  MODE , M, KARD (83 ) , KARG , ARG , ARG2 , NEWCD (80 ) , KRDEND 
COMMON  /CONSTS/  PI ,E ,HALFPI ,DEG ,RAD ,XALOG 

THIS  SUBROUTINE  ASSEMBLES  A  FLOATING  POINT  NUMBER  FROM  A  STRING 
DIGITS  ETC.  M  INITIALLY  POINTS  AT  THE  FIRST  NUMBER.  IT  IS  LEFT 
POINTING  AT  THE  FIRST  CHARACTER  AFTER  THE  NUMBER. 

VALUE  RETURNED  IN  ARG 

KARG  =  1  =  FLOATING  POINT,  =  0  =  INTEGER,  -1  =  ERROR. 

ARG=KARD (M) 

SIGN=1. 

JEXP=0 

IXS=1 

IEXP=0 

KARG=0 

LOOK  BACK  FOR  MINUS  SIGN  AND/OR  DECIMAL  POINT 

K=KARD (M-l ) 

IF  (K.NE.37)  GO  TO  10 

KARG=1 

IEXP=-1 

K=KARD (M-2 ) 

IF  (K.EQ.38)  SIGN=-1. 

M=M+1 

K=KARD (M) 

IF  (K.GE.10)  GO  TO  30 
IEXP=IEXP-KARG 
ARG=10 . *ARG+FLOAT (K) 
GO  TO  20 

IF  (K.NE.37)  GO  TO  50 

DECIMAL  POINT  FOUND 

IF  (KARG.EQ.O)  GO  TO  40 

CALL  ERROR  (3) 

KARG=-1 

RETURN 

KARG-1 

GO  TO  20 

CHECK  FOR  EXPONENT      E  X,  E+X ,  E-X ,  +X ,  -X 

IF  (K.NE.14)  GO  TO  65 

M=M+1 

K=KARD (M) 

IF  (K.NE.44)  IF  (K-10)  70,65,65 

M=M+1 

K=KARD(M) 

IF  (K-10)  70,90,90 

IF  (K.NE.38)  IF  (K-39)  90,60,90 

IXS=-1 

GO  TO  60 

KARG=KARG+1 

JEXP=10*JEXP+K 


AAR 
AAR 
AAR 
AAR 
AAR 
OFAAR 
AAR 
AAR 
AAR 


10 
20 
30 
40 
50 
60 
70 
80 
90 


AAR  100 
AAR  110 
AAR  120 
AAR  130 
AAR  140 
AAR  150 
AAR  160 
AAR  170 
AAR  180 
AAR  190 
AAR  200 
AAR  210 
AAR  220 
AAR  230 
AAR  240 
AAR  250 
AAR  260 
AAR  270 
AAR  280 
AAR  290 
AAR  300 
AAR  310 
AAR  320 
AAR  330 
AAR  340 
AAR  350 
AAR  360 
AAR  370 
AAR  380 
AAR  390 
AAR  400 
AAR  410 
AAR  420 
AAR  430 
AAR  440 
AAR  450 
AAR  460 
AAR  470 
AAR  480 
AAR  490 
AAR  500 
AAR  505 
AAR  510 
AAR  520 
AAR  530 
AAR  535 
AAR  540 
AAR  550 
AAR  560 
AAR  570 
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M=M+1 

AAR 

580 

K=KARD (M) 

AAR 

590 

IF  (K.LT.10)  GO  TO  80 

AAR 

600 

c 

AAR 

610 

c 

DONE  WITH  ARGUMENT 

AAR 

620 

c 

AAR 

630 

90 

IF  (KARG.NE .0)  GO  TO  110 

AAR 

640 

100 

ARG=SIGN*ARG 

AAR 

650 

RETURN 

AAR 

660 

110 

KARG=1 

AAR 

670 

IEXP=IXS*JEXP+IEXP 

AAR 

680 

C 

AAR 

690 

C 

THE  FOLLOWING  CODING  YIELDS 

MORE  ACCURATE  RESULTS  THAN  THE 

AAR 

700 

c 

OBVIOUS        ARG  =  ARG  *  10 . 

*  IEXP 

AAR 

710 

c 

AAR 

720 

JEXP=IABS ( IEXP) 

AAR 

730 

IF  (J EXP . GT . I F I X (XALOG)  )  GO 

TO  140 

AAR 

740 

IF  (IEXP)  120,100,130 

AAR 

750 

120 

ARG=ARG/FEXP2 (10.0, FLOAT (JEXP) ) 

AAR 

760 

GO  TO  100 

AAR 

770 

130 

ARG=ARG*FEXP2 (10.0, FLOAT (JEXP) ) 

AAR 

780 

GO  TO  100 

AAR 

790 

140 

CALL  ERROR  (102) 

AAR 

800 

ARG=0. 

AAR 

810 

GO  TO  100 

AAR 

820 

END 

AAR 

830 
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SUBROUTINE  ABRIDG  ABR  10 

C         VERSION    5.00         ABRIDG         5/15/70  ABR  20 

C  ABR  30 

C         THE  COMMAND  ABRIDGE  MAY  BE  USE  IN  THE  FOLLOWING  WAYS  ABR  40 

C         ABRIDGE    ROW,,  OF  COL  ++,++,   (USE  RPRINT  UNLESS  IOSWT  HAS  BEEN        ABR  50 

C                                                                 SET  BY  FIXED  OR  FLOATING)  ABR  60 

C         ABRIDGE  //  ROW,,  OF  COL  ++,++       (USE  SPECIFIED  FORMAT)  ABR  70 

C         ABRIDGE    WITH  FLOATING  PT .  ARGS  USES  RPRINT  ABR  80 

C                                                       IOSWT  IS  NOT  RESET  ABR  90 

C  ABR  100 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG  ABR  110 

COMMON  /BLOCRC/  NRC ,RC (12600)  ABR  120 

DIMENSION  ARGS(IOO)  ABR  130 

EQUIVALENCE  ( ARGS ( 1 ), RC  ( 12501 ) )  ABR  140 

COMMON  /FMAT /  I FMTX (6 ) , IOSWT , IFMTS (6 ) , LHEAD (96 )  ABR  150 

COMMON  /HEADER/  NOCARD (80 ) , ITLE (60 , 6 ) , LNCNT , I  PRINT , NPAGE , I  PUNCH      ABR  160 

COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NABR  170 

1ARGS , VWXYZ (8 ) ,NERROR  ABR  180 

COMMON  /KFMT /  KFMT(IOO)  ABR  190 

IF  (NARGS.NE.O)  GO  TO  15  ABR  200 

10        CALL  ERROR  (205)  ABR  210 

RETURN  ABR  220 

15        IF  (L2.EQ.1)   IF  (IOSWT)  70,70,80  ABR  225 

CALL  PREPAK  (4 , IND ,L2 , IND ,KFMT)  ABR  230 

IF  (IND.NE.O)  GO  TO  90  ABR  240 

IP=1  ABR  250 

IF   (NARGS.LE.l)  GO  TO  10  ABR  260 

20        LL=IARGS(1)  ABR  270 

IARGS(1)=1  ABR  280 

IF  (LL.LE.O.OR.LL.GT.NROW)  GO  TO  10  ABR  290 

CALL  CHKCOL  (I)  ABR  300 

IF  (I  .NE.O)  GO  TO  10  ABR  310 

IF  (NERROR.NE.O)  RETURN  ABR  320 

DO  30  I=2,NARGS  ABR  330 

J=IARGS(I)+LL  ABR  340 

30        ARGS(I)=RC(J-1)  ABR  350 

IF  (NPAGE. EQ.O)  CALL  PAGE(O)  ABR  355 

GO  TO  (40,50) ,  IP  ABR  360 

40        WRITE  (IPRINT ,KFMT)   (ARGS ( I ) , 1=2 , NARGS )  ABR  370 

GO  TO  60  ABR  380 

50        WRITE  (IPRINT, IFMTX)    (ARGS ( I ), 1=2 , NARGS)  ABR  390 

60        RETURN  ABR  400 

70        IF(NPAGE.EQ.O)  CALL  PAGE(O)  ABR  410 

CALL  RPRINT  ABR  420 

RETURN  ABR  430 

C         USE  SPECIFIED  FIXED  OR  FLOATING  FORMAT  ABR  470 

80        IP=2  ABR  480 

GO  TO  20  ABR  490 

90        CALL  ERROR  (222)  ABR  500 

GO  TO  70  ABR  510 

END  ABR  520 
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SUBROUTINE  ACCDIG  (AX,X,AD,N)  ACC  10 

C          VERSION     5.00          ACCDIG          5/15/70  ACC  20 

C         RETURNS  NUMBER  OF  ACCURATE  DIGITS,  AD,  IN  AX  AN  APPROXIMATION  TO  XACC  30 

C         WRITTEN  BY  DAVID  HOGBEN ,  SEL ,  NBS .  10/29/69.                                   ACC  40 

DATA  ADMAX  /8.0/  ACC  50 

DIMENSION      AX(1) ,X(1)  ,AD(1)  ACC  60 

DO  100  1=1, N  ACC  70 

DIFF  =  AX(I)-X(I)  ACC  80 

IF   (DIFF)  20,10,20  ACC  90 

10        AD  (I )  =  ADMAX  ACC  100 

GO  TO  100  ACC  110 

20        AD  ( I )  =  -FL0G10 (ABS (DIFF) )  +  FL0G10 (ABS  (X  ( I ) )   )  ACC  120 

AO ( I )  =  AMIN1 (ADMAX , AD ( I )   )  ACC  130 

AD ( I )  =  AMAX1 (-ADMAX ,AD (I ) )  ACC  140 

100      CONTINUE  ACC  150 

RETURN  ACC  160 

END  ACC  170 


SUBROUTINE  ADRESS  (I, J)  ADR  10 

C         VERSION    5.00         ADRESS         5/15/70  ADR  20 

COMMON  /BLOCRC/  NRC , RC ( 12600 )  ADR  30 

COMMON  /BLOCKD /  I ARGS ( 100 ) ,KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NADR  40 

1ARGS ,VWXYZ (8) ,NERROR  ADR  50 

DIMENSION  ARGS(IOO)  ADR  60 

EQUIVALENCE  ( ARGS ( 1 ), RC  ( 12501 )  )  ADR  70 

C  ADR  80 

C                CALCULATE  ADDRESS  OF  ARGUMENT (  I  ).   IF  ARGUMENT (  I   )   IS  A         ADR  90 

C                FLOATING  POINT  NUMBER,  J  =  -(1+  NRC).   IF  ILLEGAL  COLUMN  NUMBERADR  100 

C                J  =  0.     IF  OK,  J  =  ADDRESS  ADR  110 

C  ADR  120 

IF  (KIND (I ) .EQ.O)  GO  TO  10  ADR  130 

J=-(I+NRC)  ADR  150 

GO  TO  30  ADR  160 

10        IF  (IARGS(I)  .GE. LAND. IARGS(I)  .LE. NCOL)  GO  TO  20  ADR  170 

J=0  ADR  180 

GO  TO  30  ADR  190 

20        J=NR0W*(IARGS(I)-1)+1  ADR  200 

30        RETURN  ADR  210 

END  ADR  220 
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c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 


c 
c 
c 

10 
20 

c 
c 
c 

30 


c 
c 
c 
c 

40 

50 

60 

70 

80 

90 

100 

110 

120 

130 


SUBROUTINE  AERR  (I) 

VERSION    5.00         AERR  5/15/70 

COMMON  /BLOCKC/  KIO,INUNIT, I  SCR AT , KBDOUT ,KRDKNT , LL I  ST 
COMMON  /BLOCKX/  INDEX  (6  ,8)  , LEVEL 
COMMON  /SPRV/  NERCON ,NERR , ISWERR 


AER 
AER 
AER 
AER 
AER 
AER 

WHEN  ARITHMETIC  TROUBLES  DEVELOP,  THIS  ROUTINE  TALLIES  THEM  AND  THAER 
PRINTS  THE  RESULTS  WHEN  THE  COMMAND  IS  DONE.  AER 

AER 

ARIHMETIC  MESSAGES  MUST  HAVE  THE  FOLLOWING  TYPE  OF  FORMAT:  AER 

1)  THE  FIRST  TWO  CHARACTERS  MUST  BE  **  AER 

2)  MESSAGE  PLUS  OTHER  INFO  MUST  NOT  BE  LONGER  THAN  84  CHARACTERSAER 

3)  IF  MESSAGE  IS  LESS  THAN  84  CHAR  ,  ADD  NX  AT  END  OF  FORMAT  AER 

AER 

IF  MORE  THAN  10  ARITHMETIC  ERROR  MESSAGES  ARE  NEEDED  THEN  AER 
DIMENSION  OF  MESS (10)  MUST  BE  CHANGED  AND  KMESS  MUST  BE  SET  =  AER 
TO  DIMENSION    SIZE  OF  MESS.  AER 

ALSO  COMPUTED  GO  TO  MUST  BE  CHANGED.  SEE  NOTEAER 
DIMENSION  MESS(IO)  AER 
DATA  KMESS/ 10/  AER 
IF  (I)  160,30,10 

DATA  COMING  IN 

J=MINO ( I , KMESS) 
MESS(J)=MESS(J)+1 
RETURN 

DUMP  RESULTS,  END  OF  COMMAND 


IF(LLIST.LT.2.0R.LLIST.EQ.4)  GO  TO  160 

DO  150  J=l, KMESS 

IF  (MESS(J) .EQ.O)  GO  TO  150 

WRITE  (ISCRAT,250) 

WRITE  (ISCRAT,180)  MESS(J) 

THIS  COMPUTED  GO  TO  MUST  BE  CHANGED  IF  MORE  THAT  10  ARITHMETIC 
ERRORS  ARE  ADDED 


GO  TO 
WRITE 
GO  TO 
WRITE 
GO  TO 
WRITE 
GO  TO 
WRITE 
GO  TO 
WRITE 
GO  TO 
WRITE 


GO  TO  140 


WRITE 
GO  TO 
WRITE 
GO  TO 
WRITE 


GO  TO  140 


WRITE 


40,50,60,70,80,90,100 

ISCRAT,101) 

40 

ISCRAT.102) 
40 

ISCRAT,103) 
40 

ISCRAT,104)  MESS(J) 
40 

ISCRAT,105)  MESS(J) 
40 

ISCRAT,106)  MESS(J) 


110,120,130)  ,  J 


ISCRAT,107)  MESS(J) 
140 

ISCRAT,108)  MESS(J) 
140 

ISCRAT,109)  MESS(J) 


10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
180 
190 
200 
AER  210 
AER  220 
AER  230 
AER  240 
AER  250 
AER  260 
AER  270 
AER  280 
AER  290 
AER  300 


AER 
AER 
AER 
AER 
AER 


310 
320 
330 
340 
350 


AER  360 
AER  370 
AER  380 
AER  390 
AER  400 
AER  410 
AER  420 
AER  430 
AER  440 
AER  450 
AER  460 
AER  470 
AER  480 
AER  490 
AER  500 
AER  505 
AER  510 
AER  515 


AER 
AER 
AER 
AER 
AER 


517 
520 
525 
530 
535 


ISCRAT,240)  J 


AER  540 
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140 


150 


C 
C 
C 

160 
170 


C 

180 

101 
102 
103 
104 

105 

240 
250 
106 
107 

108 

109 


IF  (LEVEL .NE . 0 )  CALL  RNDOWN 
WRITE  (ISCRAT,250) 
MESS(J)=0 
CONTINUE 

IF  (LEVEL. NE.O)  GO  TO  20 

ISWERR=0 

NERR=0 

GO  TO  20 

INITIALIZATION  SECTION 

DO  170  J=1,KMESS 

MESS(J)=0 

ISWERR=0 

NERR=0 

GO  TO  20 


16H  TIMES, 23X) 
FORMAT  (42H** 


AER  550 
AER  560 
AER  570 
AER  580 
AER  590 
AER  600 
AER  610 
AER  620 
AER  630 
AER  640 
AER  650 
AER  660 
AER  670 
AER  680 
AER  690 
AER  700 
AER  710 

FORMAT  (51H**  ARITHMETIC  FAULT  IN  ABOVE  COMMAND,  ZERO  RETURNED , 14 , AER  720 

'  AER  730 

NEGATIVE  ARGUMENT  TO  SQRT,  LOG  OR  RAISE, 42X)  AER  740 

FORMAT  (43H**  EVALUATION  OF  EXPONENT  PRODUCES  OVERFLOW, 41X)  AER  750 

FORMAT  (45H**  ARGUMENT  OUT  OF  BOUNDS  TO  INVERSE  FUNCTION , 39X)  AER  760 

FORMAT  (51H**ARGUMENT  TOO  LARGE  FOR  SIN  OR  COS,  ZERO.  RETURNED ,  14 ,  AER  770 
16H  TIMES, 23X)  AER  780 

FORMAT  (61H**BESSEL  ARGUMENTS  SCALED  TO  AVOID  OVER/UNDER  FLOW. RE  AER  790 
1TURNED,I4,6H  TIMES, 13X)  AER  800 

FORMAT  (16H**  ERROR  MESSAGE , 1 2 , 66X )  AER  810 

FORMAT  (84X)  AER  820 

FORMAT  (33H**  DIVISION  BY  ZERO,  RESULT  SET=0,I4,6H  TIMES,41X)  AER  830 

FORMAT (44H**  TRIG  FUNCTIONS  NOT  DEFINED,  RESULTS  SET=0,I4,  6H  TIMEAER  840 
IS,  30X)  AER  850 

FORMAT (66H**  ONE  OF  THE  VALUES  COMPARED  IS  ZERO,  ABSOLUTE  TOLERANCAER  860 
IE  WAS  USED, 14, 6H  TIMES, 8X)  AER  870 

FORMAT (71H*  X  FOR  ELLIPTICAL  INTEGRALS  IS  =  1.0  OR  GREATER.  RESULTAER  880 
1  IS  SET  TO  0.0.,I4,6H  TIMES, 3X)  AER  890 

END  AER  900 


409-118  OL  -  71  -  2 
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SUBROUTINE  ALLSUB  ALL  10 

C         VERSION    5.00         ALLSUB         5/15/70  ALL  20 

COMMON  /BLOCRC/  NRC  , RC  ( 12600 )  ALL  30 

COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NALL  40 

1ARGS , VWXYZ (8) ,NERROR  ALL  50 

DIMENSION  ARGS(IOO)  ALL  60 

EQUIVALENCE  (ARGS ( 1 ), RC  ( 12501  ) )  ALL  70 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG  ALL  80 

COMMON  /SCRAT/  NS  , NS2  ,  A  ( 13500 )  ALL  90 

DIMENSION  SCRA(l)  ALL  100 

EQUIVALENCE  (SCRA,A)  ALL  110 

EQUIVALENCE  (L11,LL1),   (L22.LL2)  ALL  120 

C         PROGRAMMED  BY  PHILIP  J.  WALSH  (NBS  453.40)  MAY,  1967  ALL  130 

C  ALL  140 

C  ALL  150 

C         COMMAND  IS  OF  THE  FORM  XXXX  OF  ORDER  ++  OF  COL  ++,  STORE  IN  ++        ALL  160 

C         XXXX  MAY  BE     (A)  NLSUB  FOR  NORMALIZED  LAGUERRE  POLYNOMIALS  ALL  170 

C                                (B)  LSUB    FOR  LAGUERRE  POLYNOMIALS                                 ALL  180 

C                                (C)  HSUB    FOR  HERMITE  POLYNOMIALS  ALL  190 

C                                (D)  USUB    FOR  CHEBYSHEV  POLYNOMIALS                               ALL  200 

C                                (E)  PSUB    FOR  LEGENDRE  POLYNOMIALS                               ALL  210 

C                                (F)  TSUB    FOR  CHEBYSHEV  POLYNOMIALS                               ALL  220 

C         SEE  RECURSIVE  FORMULAE  FOR  THESE  POLYNOMIALS  FURTHER  IN  CODE  ALL  230 

C         EACH  OF  THE  COMMANDS  REQUIRE  THREE  ARGUMENTS  ALL  240 

IF  (NARGS.EQ.3)  GO  TO  10  ALL  250 

CALL  ERROR  (10)  ALL  260 

GO  TO  210  ALL  270 

10        IF  (KIND(1)+KIND(3) .EQ.O)  GO  TO  30  ALL  280 

20        CALL  ERROR  (3)  ALL  290 

GO  TO  210  ALL  300 

C         CHECK  THAT  X  IS  WITHIN  WORKSHEET  AND  GET  ADDRESS  OF  ARGUMENT  COLUMALL  310 

30        CALL  ADRESS  (2,L11)  ALL  320 

IF   (Lll)  20,40,50  ALL  330 

40        CALL  ERROR  (11)  ALL  340 

GO  TO  210  ALL  350 

50        IARGS(4)=IARGS(1)+IARGS(3)-1  ALL  360 

KIND(4)=0  ALL  370 

CALL  ADRESS  (4.L22)  ALL  380 

IF  (L22.LE.0)  GO  TO  40  ALL  390 

CALL  ADRESS  (3,L22)  ALL  400 

IF  (NRMAX. NE.O)  GO  TO  60  ALL  410 

CALL  ERROR  (9)  ALL  420 

GO  TO  210  ALL  430 

60        IF  (NERROR.NE.O)  GO  TO  210  ALL  440 

I JK=LL1  ALL  450 

IJ=LL2  ALL  460 

DO  110  1=1, NRMAX  ALL  470 

SCRA(1)=RC(IJK)  ALL  480 

GO  TO  (70,70,80,80,90,90),  L2  ALL  490 

70        RC(IJ)=1.-SCRA(1)  ALL  500 

GO  TO  100  ALL  510 

80        RC (IJ)=2 .*SCRA(1)  ALL  520 

GO  TO  100  ALL  530 

90        RC(IJ)=SCRA(1)  ALL  540 

100      IJK=IJK+1  ALL  550 

110      IJ=IJ+1  ALL  560 

IF  (IARGS(l) .EQ.l)  GO  TO  210  ALL  570 

N=IARGS(1)-1  ALL  580 

DO  200  J=l, NRMAX  ALL  590 
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c 
c 
c 
c 
c 
c 
c 
c 
c 

120 


c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 

130 


c 
c 
c 
c 
c 
c 
c 

140 


c 
c 
c 
c 


IJK=LL1+J 

IJ=LL2+J 

SCRA(1)=1 .0 

SCRA(2)=RC(IJK-1) 

SCRA(3)=RC(IJ-1) 

SCRA(4)=1 .0 

SCRA(5)=2 .0 

DO  190  1=1, N 

IARGS(4)=IARGS(3)+I 

CALL  AORESS  (4,LL22) 

GO  TO  (120,130,140,150,160,170),  L2 


NORMALIZED  LAGUERRE  POLYNOMIALS 
L(N+1)  =(1 .+2 .*N-X)*L(N)-N**2  *L(N-1) 


L2       =  1  NLSUB 

RECURSION  FORMULA 

L(0)  =  1. 

L(l)  =  -X+l. 

L(2)  =  X**2  -  4.0*X  +2. 

L(3)  =-X**3  +  9  .0*X**2-18 .0*X+6 . 

L(N)=  EXP(X)* (DN/DXN(X**N*EXP(-X) ) ) 

SCRA(4)=I 

SCRA(6)=1.0+2.0*SCRA(4) 
SCRA(7)=SCRA(4)*SCRA(4) 

SCRA(8)=(SCRA(6)-SCRA(2) ) *SCRA (3 )-SCRA (7 ) *SCRA (1 ) 
GO  TO  180 
L2 


=  2  LSUB 

RECURSION  FORMULA 


LAGUERRE  POLYNOMIALS 
L(N+1)=( ( (2.*N+1)-X)*L(N)-N*L(N-1) ) / 
(N+l) 


L(0)  = 

L(l)  = 

L(2)  = 

L(3)  = 


1. 

-X+l. 
.5  (XX*2 
(-X**3  + 


-  4.*X  +2) 

9.*X**2  -  18.*  X  +6.)/6 


ALL  600 
ALL  610 
ALL  620 
ALL  630 
ALL  640 
ALL  650 
ALL  660 
ALL  670 
ALL  680 
ALL  690 
ALL  700 
ALL  710 
ALL  720 
ALL  730 
ALL  740 
ALL  750 
ALL  760 
ALL  770 
ALL  780 
ALL  790 
ALL  800 
ALL  810 
ALL  820 
ALL  830 
ALL  840 
ALL  850 
ALL  860 
ALL  870 
ALL  880 
ALL  890 
ALL  900 
ALL  910 


SEE 


ALL  920 

ABRAMOWITZ,  M.  AND  STEGUN,  I. A.,  HANDBOOK  OF  MATHEMATICAL  ALL  930 
FUNCTIONS,  NATIONAL  BUREAU  OF  STANDARDS  APPLIED  MATHEMATICSALL  940 


SERIES  55,  SUPERINTENDENT  OF  DOCUMENTS,  U.S.  GOVERNMENT 
PRINTING  OFFICE,  WASHINGTON,  D.C.  20402 


SEE 


HILSENRATH, ZIEGLER, MESSINA, WALSH, HERBOLD, ,  OMNI  TAB ,  NBS 
HANDBOOK  101  (MARCH  4,  1966)  -    FOR  FORMULAE  USED 
SCRA(4)=I 

SCRA(6)=SCRA(4)+1.0 
SCRA(7)=SCRA(4)+SCRA(6) 

SCRA(8)=( (SCRA(7)-SCRA(2) ) *SCRA (3 ) -SCRA (4 ) *SCRA ( 1 ) ) /SCRA (6 ) 
GO  TO  180 

HERMITE  POLYNOMIALS 
H(N+1)  =  2.0*X*H(N)-2.0*N*H(N-1) 


L2 


=  3  HSUB 

RECURSION  FORMULA 


H(0)  =  1. 

H(l)  =  2.0*X 

H(2)  =  4.0*X**2-2. 

H(3)  =  8.0*X**3-12.*X 
SCRA(8)=2.0*(SCRA(2)*SCRA(3)-SCRA(4)*SCRA(1) ) 
SCRA(4)=SCRA(4)+1.0 
GO  TO  180 

L2       =4  USUB  CHEBYSHEV  POLYNOMIALS 

RECURSION  FORMULA    U(N)  =  2  . 0*X*U (N-l ) -U (N-2 ) 


ALL  950 
ALL  960 
ALL  970 
ALL  980 
ALL  990 
ALL1000 
ALL1010 
ALL1020 
ALL1030 
ALL1040 
ALL1050 
ALL1060 
ALL1070 
ALL1080 
ALL1090 
ALL1100 
ALL1110 
ALL1120 
ALL1130 
ALL1140 
ALL1150 
ALL1160 
ALL1170 
ALL1180 
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C                      U(0)  =  1.  ALL1190 

C                       U(l)  =  2.0*X  ALL1200 

C                       U(2)  =  4.0*X**2-1.0  ALL1210 

C                       U(3)  =  8.0*X**3-4.0*X  ALL1220 

C  ALL1230 

150      SCRA(8)=2 .0*SCRA(2)*SCRA(3)-SCRA(1)  AlL1240 

GO  TO  180  ALL1250 

C         L2        =  5           PSUB  LEGENDRE  POLYNOMIALS  ALL1260 

C  ALL1270 
C                       RECUSION  FORMULA    P(N+1)  =X*P(N)+(N/N+1)*(X*P(N)-P (N-l ) )  ALL1280 

C  ALL1290 

C                       P(0)  =  1.  ALL1300 

C                       P(l)  =  X.  ALL1310 

C                       P(2)  =  (3./2.)*X**2-(l./2.)  ALL1320 

C                       P(3)  =  2.5*X**3-1.5*X  ALL1330 

C  ALL1340 

160      SCRA(6)=SCRA(4) /SCRA(5)  ALL1350 

SCRA(8)  =  (1 .0+SCRA(6) ) *SCRA (2 ) *SCRA (3 ) -SCRA (6 ) *SCRA  ( 1 )  ALL1360 

SCRA(4)=SCRA(5)  ALL1370 

SCRA(5)=SCRA(5)+1 .0  ALL1380 

GO  TO  180  ALL1390 

C         L2        =6           TSUB  CHEBYSHEV  POLYNOMIALS  ALL1400 

C  ALL1410 

C                       RECURSION  FORMULA  ALL1420 

C  ALL1430 

C                       T(0)  =  1.  ALL1440 

C                       T(l)  =  X  ALL1450 

C                       T(2)  =  2.*X**2-1.  ALL1460 

C                        T(3)  =  4.*X**3-3.*X  ALL1470 

170      SCRA(8)=2.0*SCRA(2)*SCRA(3)-SCRA(1)  ALL1480 

180      CONTINUE  ALL1490 

LJMN=LL22+J  ALL1500 

RC(LJMN-1)=SCRA(8)  ALL1510 
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SUBROUTINE  APRINT  APR  10 

C          VERSION     5.00          APRINT          5/15/70  APR  20 

COMMON  /BLOCRC/  NRC , RC ( 12600 )  APR  30 

COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NAPR  40 

1ARGS ,VWXYZ (8) ,NERROR  APR  50 

DIMENSION  ARGS(IOO)  APR  60 

EQUIVALENCE  (ARGS ( 1 ), RC ( 12501 ) )  APR  70 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG  APR  80 

COMMON  /ABCDEF /  L(48)  APR  90 

COMMON  /HEADER/  NOCARD (80 ) , ITLE (60 ,6 ) , LNCNT , IPRINT ,NPAGE  ,  I  PUNCH      APR  100 

COMMON  /FMAT/  IFMTX (6 ) , IOSWT , I FMTS (6 ) , LHEAD ( 96 )  APR  110 

COMMON  /SCRAT/  NS  ,NS2  ,A  (13500)  APR  120 

COMMON  /KFMT /  KFMT(IOO)  APR  130 

DIMENSION  IFRV(3)  APR  140 

DATA  IFRV(l)  ,  IFRV (2) , IFRV (3 ) /3H1X , ,3HI5, ,3H2X,/  APR  150 

C         LI  =  4  APRINT  APR  160 

C          LI  =  7  MPRINT  APR  170 

C         MPRINT  PRINTS  ROW/COL  TITLE,  APRINT  DOES  NOT.                                    APR  180 

C         ALL  READABLE  IF  POSSIBLE,  OTHERWISE  ALL  FLOATING.  APR  190 

C         WRITTTEN  BY  DAVID  HOGBEN,  SEL,  NBS .      8/18/69.  APR  200 

C         *****  APR  210 

C         6  FORMAT  STATEMENTS  FOLLOW  WHICH  MAY  NEED  MODIFY  IF  CHANGES  MADE    APR  220 

C         *****  APR  230 

IF  (NARGS.EQ.4)  GO  TO  30  APR  240 

10        CALL  ERROR  (205)  APR  250 

20        RETURN  APR  260 

30        J=l  APR  270 

1=4  APR  280 

CALL  CKIND   (I)  APR  290 

IF  (I .NE.O)  GO  TO  10  APR  300 

K=IARGS(1)  APR  310 

CALL  MTXCHK  (J)  APR  320 

IF  (J. NE.O)  GO  TO  10  APR  330 

IF  (NERROR.NE.O)  RETURN  APR  340 

C         CHECK  TO  SEE  IF  NPAGE=0 .   IF  YES,  BEGIN  A  NEW  PAGE.     CALL  PAGE(O)     APR  342 

IF  (NPAGE.EQ.O)  CALL  PAGE(O)  APR  344 

C         IF  L2=l  IOSWT=0  USE  READABLE  FORMAT  APR  350 

IF  (L2.EQ. LAND. IOSWT. EQ.O)  GO  TO  190  APR  360 

C         IF  L2=l  I0SWT=1  USE  FIXED  OR  FLOATING  APR  370 

IF  (L2.EQ. LAND. IOSWT. EQ.l)  GO  TO  60  APR  380 

C         IF  (L2.NE.1)  USE  SPECIFIED  FORMAT  APR  390 

C         FORMAT  SHOULD  SPECIFY  FORMAT  FOR  ONLY  ONE  ROW                                    APR  400 

CALL  PREPAK  (4 , IND , L2 , IND , KFMT )  APR  410 

IF  (IND. NE.O)  GO  TO  50  APR  420 

IA=IARGS(3)  APR  440 

J1=IARGS(1)  APR  450 

J2=J1+(IARGS(4)-1)*NR0W  APR  460 

DO  40  I=1,IA  APR  470 

WRITE  (IPRINT, KFMT)   (RC (J ) , J=J1 , J2 ,NROW)  APR  480 

J 1=J 1+1  APR  490 

J2=J2+1  APR  500 

40        CONTINUE  APR  510 

RETURN  APR  520 

C         NO  FORMAT  IS  FOUND  SO  USE  READABLE  FORMAT  APR  530 

50        CALL  ERROR  (222)  APR  540 

GO  TO  190  APR  550 

C         FIXED  OR  FLOATING  FORMAT  USED  APR  560 

60        DO  70  1=1,100  APR  570 

70       KFMT(I)=L(45)  APR  590 
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lr    (Ll.ty./)  bU   IU  vo 

ADD  irtrt 

APK  600 

nn  on   T   i  l 
UU  oU   1=1  ,  o 

ADD    L 1 n 
ArK  010 

80 

1/  C  HAT  /  T  \     T  C  MT  V  /  T  \ 

KrMI  ( 1 )=irMI A ( 1 ) 

ADD    L 1 n 

ArK  620 

bU    1  U  111) 

ADD    L 1 n 
ArK  030 

a  n 

C  MT  /  1  \     I  C  MT  Y  /  1  \ 

KrMI  ( 1 )=1 rml a ( 1 ) 

ADD     L A  A 

ArK  040 

KrMI  (£.  )=lr KV  ( i ) 

ADD     L C  n 

ArK  ODD 

V C  MT  I W     ICDW  (1\ 

l\r  M I  (3  )  =1  r It V  (c  ) 

ADD    L L n 
ArK  ooU 

V C MT  t  A  \     I CDW  ( I \ 

KrMI (4 ) =1 r K V  ( 3  ; 

ADD     L 7  n 

ArK  670 

nn  inn  T — o  a 
UU   1UU    l  =  c  ,  0 

ADD    L Q  n 

ArK  080 

inn 
100 

V C  MT ( T  i 3 \     TC MT  Y  /  T  \ 
NrMI  (  1  +  3  )  =  1  r  M  1  A  (  1  ) 

ADD    L o  n 

ArK  070 

1  iU 

V  A     T  A DT C  /  1  \ 
l\A=lAKbo  (1  ) 

add   7  n  n 
ArK  700 

II     T  A  DP  C  / 1 \ 
l_L=l  AKbo  (  3 ) 

ADD    7 1 rt 

ArK   / 10 

TDD  TADTC/JIN 
1 DD=1 AKbb (4 ) 

ADD     7  9  A 

APK  7Z0 

T  DDD  Q 
1 DDr=8 

ADD     7 1  A 

ArK  730 

TC     /I  l    Cn    7\     TRDD  7 
lr     (.Li.ty./)     1  Bur  =  / 

ADD     7  A  A 

ArK    / 4U 

T1A     1 ADPC  (1  \ 
l lA=l AKbb  (  Z  ) 

inn    ■»  c  A 

AHK  750 

1  O  A 

1Z0 

TC     /TDD    r*T    TDDD\    rfl    TO  Tin 

lr    (iDD.bl  .  I  dor  )   bU   IU  130 

ADD 

ArK  760 

T  D    T  DO 
1 D=l DD 

ADD     7  7  A 

ArK  770 

TDD  n 
1  DD=U 

ADD     7  0 A 

ArK  /oO 

r  n  Tn  i  a n 
bU    1 U  14U 

ADD     7  Q  A 

ArK  /VO 

130 

TDD     TDD  TDDD 
1 DD=1 DD— 1 OOP 

ADD  AAA 

APK  800 

T  D    T  DDD 
1 D=l DDK 

ADD     O 1  A 

ArK  810 

'\  An 
140 

k  D     I  IB    1  \  *  MDftUI  .  V  A 
l\D=  (  ID  — 1 )  NKUW+lsA 

ADD     O 1 A 

ArK  8Z0 

j/OD    I/O  .  KIDDU1 
l\Dr=l\B+IMKU  n 

ADD    0 1  A 

ArK  830 

T  9  A  — T lA ,!R  l 
1  &  A= 1 ift  +  lD-1 

ADD    Q A  A 
ArK  840 

IF  (L1.EQ.4)  GO  TO  150 

APR  850 

WRITE   (IPRINT,280)  L  (28 )  ,  L  (25 ) , L (33 ) , L (37 ) , L ( 13 ) , L (25 ) , L (22 ) , ( J J , JAPR  860 

1 J=l 1A , 1 2A ) 

APK  870 

MK  v=K. 

ADD  AAA 

ArK  880 

1  DU 

r\  A    ion    if    i  II 

UU   180  M=l , LL 

A  H  D  AAA 

APR  890 

tc   i\  i   cn  a\  rn  Tn  un 
lr    l  L 1  .  ty . 4 )   bU    IU  loo 

A  DD     OA A 

ArK  900 

WRITE  ( I  PR  I NT ,KFMT)  MRV , (RC(K) ,K=KA , KB , NR0W) 

APR  910 

MRV=MRV+1 

APR  920 

GO  TO  170 

APR  930 

i  ou 

WRITE  (IPRINT ,KFMT)   (RC(K) , K=KA , KB , NR0W) 

APR  940 

1/0 

KA=KA+1 

APR  950 

KB=KB+1 

APR  960 

ion 
180 

CONTINUE 

APR  970 

IF  (IBB.EQ.0)  RETURN 

APR  980 

WRITE  (IPRINT, 330) 

APR  990 

C 

PRINT  NEXT  SET  OF  COLUMNS 

APR1000 

KA=KBP 

APR1010 

I1A=I2A+1 

APR1020 

GO  TO  120 

APR1030 

c 

THE  NEXT  CARD  MUST  BE  CHANGED  IF  WIDTH  OF  COLUMN  CHANGED 

APR1040 

c 

THE  CARD  AFTER  IT  MUST  BE  CHANGED  IF  NUMBER  OF  COLUMNS  CHANGES 

APR1050 

c 

2  CALLS  TO  RF0RMT  LATER  NEED  TO  BE  CHANGED  IF  NO.  OF  SD  NOT  8. 

APR1060 

c 

NWMX  IS  DETERMINED  BY  120/8-2  WHERE  120  IS  THE  NUMBER  OF 

APR1070 

c 

CHARACTERS  PER  PRINTED  LINE 

APR1080 

1  OA 

190 

NWMX=13 

APR1100 

MC0L=8-Ll/7 

APR1110 

NSTART=IARGS (1) 

APR1120 

KSTART=K-1 

APR1130 

KR=IARGS(3) 

APR1140 

KC=IARGS(4) 

APR1150 

Kl=l 

APR1160 

K2=NSTART 

APR1170 

DO  210  I=1,KC 

APR1180 

DO  200  J=1,KR 

APR1190 

18 


240 
C 

250 


GO  TO  240 

i  AND  NWIDTH  GT  NWMAX 


A(K1)=RC(K2) 

K1=K1+1 
200  K2=K2+1 
210  K2=K2+NROW-KR 

KSIZE=KR*KC 

CALL  RFORMT  (A (1 ) ,KSIZE , 8 , NWIDTH ,NDECS , NWMX+1 ,A(1) ,A(1) ,0,0) 
C         MINIMUM  OF  TWO  BLANK  SPACES  ON  LEFT 
NBLANK=NWMX+2 -NWIDTH 
11=1 

I1A=IARGS(2) 

K1=NSTART-1 
C         LOOP  ON  BLOCKS 
220  I2=I1+MC0L-1 

I2=MIN0(I2,KC) 

I2A=IARGS(2)+I2-1 

K2=K1+(I2-I1)*NR0W 

K4=K2 

IF  (L1.EQ.4)  GO  TO  230 

WRITE  (I  PR  I  NT, 280)  L (28 ) , L (25 ) , L (33 ) , L (37 ) , L ( 13 ) , L ( 25 ) , L  ( 22 )  ,  ( J J 
1J=I1A,I2A) 
C         LOOP  ON  ROWS 
230      DO  270  JJ=1,KR 

K1=K1+1 

K2=K2+1 

JJJ=KSTART+JJ 

IF  (NWIDTH . LE .NWMX .OR .LI .NE .7 ) 
C         WRITE  FLOATING  IF  MPRINT  (Ll=7; 

WRITE  (IPRINT,300)  J J J , (RC (K3 ) , K3=K1 , K2 , NROW) 
GO  TO  270 
LL=1 
K=K1 

LOOP  ON  COLUMNS 
DO  250  11=11,12 

CALL  RFORMT  (A , 1 , 8 , NWIDTH , NDECS , 0 , RC (K) , A (LL ) , NBLANK , 0 ) 
K=K+NROW 
LL=LL+NWMX+2 
NL=LL-1 

IF  (L1.EQ.7)  GO  TO  260 
WRITE  (IPRINT,310)   (A (LL ) , LL=2 , NL ) 
GO  TO  270 

260      WRITE  (IPRINT,290)  J J J , (A (LL ) , LL=2 ,NL ) 
270  CONTINUE 

K1=K4+NR0W 

I1=I1+MC0L 

I1A=I1A+MC0L 

IF  (I2.GE.KC)  GO  TO  20 
C         LOOP  ON  BLOCKS 

C         PUT  IN  BLANK  LINE  BETWEEN  BLOCKS 
WRITE  (IPRINT,320) 
GO  TO  220 

C 

280      FORMAT  (IX , 7A1 , 7 (6X , 1 5 ,4X ) ) 
290      FORMAT  (IX , 1 5 , 2X , 112A1 ) 
300      FORMAT  (IX , 15 , 2X , 1P7E15  .  6 ) 
310      FORMAT  (1X.119A1) 
320      FORMAT  (1H  ) 
330      FORMAT  (IX) 
END 


APR1200 
APR1210 
APR1220 
APR1230 
APR1240 
APR1250 
APR1260 
APR1270 
APR1280 
APR1290 
APR1300 
APR1310 
APR1320 
APR1330 
APR1340 
APR1350 
APR1360 
APR1370 
,JAPR1380 
APR1390 
APR1400 
APR1410 
APR1420 
APR1430 
APR1440 
APR1450 
APR1460 
APR1470 
APR1480 
APR1490 
APR1500 
APR1510 
APR1520 
APR1530 
APR1540 
APR1550 
APR1560 
APR1570 
APR1580 
APR1590 
APR1600 
APR1610 
APR1620 
APR1630 
APR1640 
APR1650 
APR1660 
APR1670 
APR1680 
APR1690 
APR1700 
APR1710 
APR1720 
APR1730 
APR1740 
APR1750 
APR1760 
APR1770 
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SUBROUTINE  ARITH  ARI 

VERSION    5.00        ARITH        5/15/70  ARI 

COMMON  /BLOCRC/  NRC , RC ( 12600 )  ARI 
COMMON  /BLOCKD /  IARGS(IOO) , KIND (100) , ARGTAB (100 ) , NRMAX ,NROW,NCOL  ,NARI 

1ARGS , VWXYZ (8 ) ,NERROR  ARI 

DIMENSION  ARGS(IOO)  ARI 

EQUIVALENCE  ( ARGS ( 1 ), RC  ( 12501 ) )  ARI 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG  ARI 

DIMENSION  11(5) ,KK(5)  ARI 

EQUIVALENCE  (11(1)  ,11) , (11(2)  ,12) , (II  (3) ,13) ,  ARI  100 

1   (II (4) ,14) , (II (5)  ,15)  ARI  105 

ARI  110 

THIS  SUBROUTINE  PERFORMS  ADD , SUB , MULT , DIV  AND  RAISE  FOR  ARI  120 

THREE,  FOUR  AND  FIVE  ARGUMENTS  ARI  130 

L2=l      ADD  ARI  140 

L2=2      SUBTRACT  ARI  150 

L2=3      MULTIPLY  ARI  160 

L2=4      DIVIDE  ARI  170 

L2=5      RAISE  ARI  180 

L2=6      ACCURATE  DIGITS  ARI  190 

ARI  200 

I F (NARGS . LT . 3 .OR . NARGS .GT . 5 )  CALL  ERROR(IO)  ARI  210 

IF  (NARGS. EQ.4)CALL  ERROR  (29)  ARI  215 

IF (KIND  (NARGS)  .NE .0)  CALL  ERROR  (20)  ARI  220 

IF   (L2.NE.6)     GO  TO  5  ARI  222 

IF  (NARGS. EQ. 3)     GO  TO  5  ARI  224 

CALL  ERROR  (212)  ARI  226 

NARGS=3  ARI  228 

DO  30     1=1, NARGS  ARI  230 

KK(I)=1  ARI  240 

CALL  ADRESS   (I  ,  II  (I ) )  ARI  250 

I F  ( 1 1  ( I ) )  20,10,30  ARI  260 

CALL  ERROR(ll)  ARI  270 

RETURN  ARI  280 

KK(I)=0  ARI  290 

1 1 ( I )=-1 1(1)  ARI  300 

CONTINUE  ARI  310 

IF (NRMAX . LE . 0 )  CALL  ERROR (9 )  ARI  320 

IF  (NERROR .NE . 0)  RETURN  ARI  330 

J J=I I (NARGS ) +NRMAX-1  ARI  380 

I F (NARGS .NE . 3 )  GO  TO  120  ARI  390 

DO  110      1=13, JJ  ARI  400 

GO  TO   (50,60,70,80,90,95)  ,L2  ARI  410 

RC(I)=RC(I1)+RC(I2)  ARI  420 

GO  TO  100  ARI  430 

RC ( I )=RC ( 12 )-RC (II)  ARI  440 

GO  TO  100  ARI  450 

RC ( I )=RC(I1)*RC(I2)  ARI  460 

GO  TO  100  ARI  470 

IF (RC (12) .NE.O.O)  GO  TO  85  ARI  480 

RC(I)=0.0  ARI  490 

CALL  ERROR  (106)  ARI  500 

GO  TO  100  ARI  510 

RC ( I )=RC (II) /RC  (12)  ARI  520 

GO  TO  100  ARI  530 

RC ( I )=FEXP2 (RC ( 1 1 ) , RC  ( 12  ) )  ARI  540 

GO  TO  100  ARI  545 

CALL  ACCDIG (RC ( 1 1 ) , RC (12) ,RC  ( I )  ,  1 )  ARI  547 

1 1=1 1+KK ( 1 )  ARI  550 
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ARI  560 

110      I2=I2+KK(2)  ARI  570 

RETURN  ARI  580 

120      IF (NARGS .EQ . 5 )  GO  TO  130  ARI  590 

15=14  ARI  600 

KK(5)=KK(4)  ARI  610 

130      DO  200      1=15, JJ  ARI  620 

GOTO  (140,150,160,170,180)  ,L2  ARI  630 

140      X=RC(I1)+RC(I2)  ARI  640 

GO  TO  190  ARI  650 

150      X=RC(12)-RC(ID  ARI  660 

GO  TO  190  ARI  670 

160      X=RC(I1)*RC(I2)  ARI  680 

GO  TO  190  ARI  690 

170      IF(RC(I2) .NE.O.O)  GO  TO  175  ARI  700 

X=0.0  ARI  710 

CALL  ERROR  (106)  ARI  720 

GO  TO  190  ARI  730 

175      X=RC(I1) /RC(I2)  ARI  740 

GO  TO  190  ARI  750 

180      X=FEXP2(RC(I1) ,RC(I2) )  ARI  760 

190      RC(I)=X*RC(I3)+RC(I4)  ARI  765 

I1=I1+KK(1)  ARI  770 

I2=I2+KK(2)  ARI  775 

I3=I3+KK(3)  ARI  780 

I4=I4+KK(4)  ARI  785 

200      CONTINUE  ARI  790 

RETURN  ARI  800 
END 
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SUBROUTINE  ARYVEC  ARY  10 

C         VERSION    5.00         ARYVEC         5/15/70  ARY  20 

C         SUBROUTINE  ARYVEC    R.VARNER      9/27/67  ARY  30 

C         *  ARY  40 

C         SUBROUTINE  TO  MULTIPLY  MATRIX  TIME  VECTOR  ARY  50 

C                                         OR  VECTOR  TRANSPOSE  TIME  MATRIX  ARY  60 

C         L2=l  MULTIPLY  MATRIX  TIME  VECTOR  ARY  70 

C  GENERAL  FORM  OF  COMMAND  ARY  80 
C  M(AV)  A  (,)  N,K  VECTOR  IN  COL  I  STORE  IN  COLUMN  J  ARY  90 
C                        M(AV)     A  (,)  N,K      VECTOR  IN  COL  I     STORE  IN  ROW  K  COL  J  ARY  100 

C                                 N  AND  K  MUST  BE  SPECIFIED  ARY  110 

C         L2=2  MULTIPLY  VECTOR  TRANSPOSE  TIMES  MATRIX  ARY  120 

C                  GENERAL  FORM  OF  COMMAND  ARY  130 

C  M(V/A)  A  (,)  N,K  VECTOR  IN  COL  I  STORE  IN  ROW  J  ARY  140 
C                        M(V/A)  A  (,)  N,K    VECTOR  IN  COL  I     STORE  IN  ROW  K  COL  J    ARY  150 

C  N  AND  K  MUST  BE  SPECIFIED  ARY  160 
C                                 IF  ONLY  ROW  IS  GIVEN  FOR  STORAGE    COL    1  IS  ASSUMED  ARY  170 

C         *  ARY  180 

COMMON  /BLOCRC/  NRC , RC  ( 12600 )  ARY  200 
COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NARY  210 

1ARGS , VWXYZ (8 ) ,NERROR  ARY  220 

DIMENSION  ARGS(IOO)  ARY  230 

EQUIVALENCE  (ARGS  ( 1 ), RC  ( 12501 ) )  ARY  240 

COMMON  /SCRAT/  NS  ,NS2 ,A (13500 )  ARY  250 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG  ARY  260 

DIMENSION  X(l)  ARY  270 

DOUBLE  PRECISION  X(SUM  ARY  280 

EQUIVALENCE  (X,A)  ARY  290 

C         *  ARY  310 

C         CHECK  FOR  CORRECT  NUMBER  OF  ARGUMENTS  ARY  320 

C         *  ARY  330 

IF  (NARGS . NE  . 6  .  AND . NARGS  . NE  .  7 )  CALL  ERROR  (10)  ARY  340 

C         *  ARY  350 

C         CHECK  TO  SEE  IF  ALL  ARGUMENTS  ARE  INTEGERS  ARY  360 

C         *  ARY  370 

J=NARGS  ARY  380 

CALL  CKIND  (J)  ARY  390 

IF  (J.NE.O)  CALL  ERROR   (3)  ARY  400 

C         *  ARY  410 

C         CHECK  TO  SEE  IF  DIMENSIONS  ARE  OUT  OF  RANGE  ARY  420 

C         *  ARY  430 

GO  TO  (10,20)  ,  L2  ARY  440 

10        IADD=IARGS(4)  ARY  450 

IADD2=IARGS(3)  ARY  460 

ICOMP=NROW  ARY  470 

GO  TO  30  ARY  480 

20        IADD=IARGS(3)  ARY  490 

I ADD2=I ADD  ARY  500 

ICOMP=NCOL  ARY  510 

IF  (NARGS. NE. 6)  GO  TO  30  ARY  520 

IF  (IARGS(6) .GT. NROW. OR. IARGS(4) .GT. NCOL)  CALL  ERROR  (17)  ARY  530 

C         *  ARY  540 

C         COMPUTE  ADDRESSES  OF  COLUMNS  ARY  550 

C         *  ARY  560 

30        IARGS(10)=IARGS(NARGS)  ARY  570 

IARGS(8)=1  ARY  580 

GO  TO  (70,40)  ,  L2  ARY  590 

40        IF  (NARGS. EQ. 7)  GO  TO  50  ARY  600 

J=2  ARY  610 
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T  r»  A  IIIC  W     T  lore  /  z  \ 

IR0W5V=IARGb (6) 

a  n  w  /oa 

AKY  620 

A  A     T  A     Z.  A 

GU   IU  60 

AKY  030 

50 

t  adpc  /  n  \  TADPC/>1\ 
IAKb:>(l<i)  =  lAKbb(4) 

A  D  V     L  A  A 

AKY  o40 

T  ADPC  /  1  1  \  1 

1  AKGb ( 1 1 )=1 

A  D  V  itn 
AKY  000 

I ARGS (9 )=IARGb (6 ) 

A  D  \J      Z  Z  A 

ARY  660 

1  1 

J=3 

A  D  V     L  7  A 

AK  Y  0/0 

60 

IARGS (7 )=IARGb (3 ) 

inw      /  A  A 

ARY  680 

A     T  A  Art 

GO  TO  90 

an  v    /  a  a 

ARY  690 

7  a 

7  0 

J  =3 

ad v  7 n n 
AK I  /uu 

T  A  DP  C  /  1  7 \  1 
1  AKlao  ( 1  c  )  =1 

A  D V    71  n 
Alt  I     /  1 U 

TADPC/11\      1 ADTC /l \ 

1  AKGb (ll)=lAKGb (3 ) 

A  DV    7  0  (1 
AKY    /  tCO 

TAOPC/7X      T  ADPC  /  X  \ 

lAKGb(7)=lAKGb(4) 

A  DV    7  "3  A 

AKY    / 30 

TC     iklADTC    cn    z  \    on    Tfl  qa 
lr    (NAKtoo  .  t(J  .  O  )    GU    IU  oU 

A  D V  Tin 

Ai\  I    /  IU 

TADOC/AX      TAD/*C  /  i\ 

lAKGb (9)=lAKGb(6) 

ft  n  V     7  C  A 

AKY  750 

rn   T  A   q  n 
GU    IU  VU 

A DV    7 AA 
AKY    / OU 

0  A 

1  AKGb (9 )=1 

A  D  V    7  7  A 
AKY    / / U 

A  A 

90 

IARGS (6)=IARGS (5) 

A  D  V      7  O  A 

AKY  780 

T  A  DP  C  /  C  \  1 

1 AKGb (5 )=1 

A  D  V     7  A  A 

AKY  790 

p  A  1  1      AIT  V  P  U 1/      /   1  \ 

LALL  Ml ALrlN    ( J ) 

A  D  V     O  A  A 

AKY  800 

TC     /I     1  \     lOA     T  A  A     1  1  A 

lr    (J-l)  120,100,110 

A  D  V    01  n 
AKY  810 

1  A  A 

100 

PAI 1     rnnnn  /o\ 

LALL  LKKUR  (3) 

A  D  V     O  A  A 

AKY  820 

D  C  T 1 1 D  M 

Kb ! URN 

ft  D V  flirt 

AKY  830 

110 

LALL  tKRUK  (17) 

ft  D  V      O  A  A 

AKY  840 

DCTIIDM 

Kt 1 UKN 

ft  n  W  OCA 

AKY  850 

p 

A  D  V  QftA 
AKY  000 

p 

L 

purpi/    CAD    DDCV/TAIIC  CDDADC 

LrltLK  rUK  KKtvlUUb  tKRUKb 

A  D  V     O  7  A 

AKY  870 

p 
L 

* 

A  D  V     O  O  A 

AKY  880 

1  7  A 

12U 

TC     /MCDDOD    KIC    A\  DCTIIDM 
lr    ( NtKKUK  .  IMt  .  0  )    Kt  1  UKN 

A  D  V     Q  A  A 

AKY  890 

PA  TA    n  l/i    "i  a  n  \  lo 
GU    1 U    ( 130 , 140 )  ,  L2 

A  D  V      ft  ft  A 

AKY  900 

1  i  u 

T  P  C     T  ADrC  /  O \ 
lLo=lAKbo (7 ) 

A  D  V     ft  l  ft 

AKY  910 

TAD    T  A  DP  C  /  1  N 
1 Ar=iAKbo ( 1 ) 

A  D  V  flirt 

AKY  9^0 

T  D    T  A  DP  C  1  1  \ 

lr=lAKlao  (3  ) 

A  O  V     A  1  A 

AKY  930 

ID     T  A  DP  C  /  il  \ 

Jr=l AKGb (4 ) 

ADV      ft  A  ft 

ARY  940 

TAni     M  D  A  Uf 

1AU1=NKUW 

ft  D  V      A  C  A 

ARY  950 

T  a  n  0  1 
1  AU  £=i 

A  D  V    Q  L  A 

AKY  VoO 

TDD  TADPC/E\ 

1 br=l AKGb ( 5 ) 

ft  D  w     A  7  A 

AKY  970 

pn  ta  i  7  a 
GU    1 U  170 

A  D  V     A  O  A 

AKY  980 

14U 

TDD    TADPC/1  \ 
lDr=lAKGb  (  1 ) 

ft  D  V  AAA 

AKY  990 

TAD  TADPC/C\ 

1 Ar=l AKGb ( 5 ) 

A  D V 1  AAA 

AKY 1000 

T  D    T  ADP  C  1  A  \ 

1 r=l AKiao ( 4 ) 

A  D  V  1  A  1  A 

AKY1010 

TC     / M  A  DP  C    CA    7\    PA    TA  1CA 
lr    ( IMAKlaO  .  tU.  .  /  )    GU    IU  lbU 

A  D  V 1  AAA 

AKY 1020 

in     T  A  DP  C  /  O.  \ 

Jr=lAKGb (3 ) 

«  n  W  1  ft  O  ft 

AKY1030 

T  P  C     T  D  A  UiC  W 

ILb=lKUWbV 

AO\/i  a  A  ft 

AKY1040 

PA    T A  lift 

GU    IU  160 

A  DV 1  A  C A 

AKY 1050 

TEA 
150 

ID    T  A  DP  C  /  a  \ 
Jr=lAKGb (3 ) 

ADVl  A  L A 

AKY 1060 

TPC  TADPC/AX 

ILb=lAKGb (9 ) 

AQUl  ft  "T  ft 

ARY1070 

1  Z.  A 

160 

1AU1=1 

A  QUI  ft  ft  ft 

ARY1080 

T  A  n  A     Al  D  A  Uf 

1 AU2=NKUW 

A  D  V 1  AAA 

ARY 1090 

1  7  A 

170 

TP  1 

1L=1 

A  O  \J  1  1  ft  ft 

ARY1100 

AA     11 n     T     1  TD 

UU  210   1=1 , lr 

A  D  V  1  1  1  A 

AKY1110 

T  A  TAD 

1 A=l Ar 

A  D  V  1  1  A  A 

AKY1120 

T  D  TDD 
1 D= 1 br 

A  D  V  1  1  1  A 

AKY1130 

T  C  IIC1 

l b=Nb2 

A  n  \f  I   1  in 

ARY1140 

n  A    l  O  A      I     l  ID 

UU   1B0  J=l , J  r 

A  D  V  1  1  C  A 

AKY 1 150 

V/TC\      D/^  /  T  A  \  ADA  /  TD  \ 

X ( IS )=RC { I A) *RC ( IB) 

A  O  V  1  1  /  A 

ARY1160 

T  C    T  C  ^ 
I b=l b-l 

ft  D  V  1  1  7  A 

ARY1170 

TA  TA.TAAl 
lA=lA+lADl 

A  D  V/  1  1  A  A 

ARY1180 

i  on 

TO    T  D i 1 
I B=  i D  +  l 

A  D V 1  1  OA 

AKY 11VU 

CALL  S0RTSM  (JP,SUM) 

ARY1200 
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A  /  T  P  \     C  1 1  M 

A  ( lb )=bUM 

A  D  V  1  1  l  f\ 

AKY 12 10 

TP     TP  ,  1 
lb=lb+l 

AK  Y  1 2  20 

PA     TP      /inn     OAA \        1 0 

bU    IU    (190, 2UU),  L2 

AKY 1 230 

190 

TAD     T  A  D  .  1 

1  AH=lAr'  +  l 

AKY 1240 

PA    T A  oin 

bl)    ID  210 

AKY 1 2  50 

1  A  A 

200 

TDD  TDD.MDAUJ 

lDr=lbr+NKUW 

ADVl  1  L  A 

AKY1260 

O  1  A 

210 

P  A  M  T  T  M 1  1 C 
bUN 1  1  NUt 

ADVl O  "7  A 

AKY1270 

p 
b 

ADVl  O  O  A 

AKY 1280 

p 
b 

o  1  UKt   KtbULIO    IN  WUKISonttl 

ADVl OOP 

AKY 12VU 

p 
b 

* 

AKY 1 3UU 

T  C  1 
1  b  =  l 

ADVl  Q  1  A 

AKY1310 

HA    OOP    T     1  TD 
UU    C£.\J    1  =  1  ,  lr 

ADVl  7  O  A 
AK  Y  1  3  e.  U 

Dp  / IPC  1  A/TC\ 

Kb ( 1 Lb ) =A ( 1  o ) 

ADVl  "3  O  A 

AKY133U 

T  C     T  C  ,  1 
1 0=1 O+l 

ADVl  "5  A  A 

AKY 1340 

TPC    IPC  ,  nni 
Ibb=lbb+1AU2 

ADVl  "J  C  A 

AKY13bU 

o  o  a 
£20 

bUN 1 1 NUt 

ADVl 1 L A 

AKY 1360 

nr  ti  mil 

RETURN 

ARY1370 

END 

ARY1380 
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SUBROUTINE  ASTER  AST  10 

C         VERSION    5.00         ASTER           5/15/70  AST  20 
COMMON  /BLOCKA/  MODE , M, KARD (83 ) , KARG , ARG , ARG2 , NEWCD (80 ) , KRDEND        AST  30 

DIMENSION  NAM(2)  AST  40 

C  AST  50 

C         ASTERISKS  HAVE  BEEN  FOUND,  LOOK  FOR  A  SPECIAL  FORM  OF  ARGUMENT.      AST  60 

C  AST  70 

C          FORMS  CAN  BE. .  AST  80 

C  AST  90 

C         *PHYSCON*        A  PHYSICAL  CONSTANT  NAME,  FL.PT.  AST  100 

C         **VARCON**      A  -VARIABLE-  CONSTANT  TO  BE  USED  AS  AN  INTEGER  (TRUN ) AST  110 

C         *VARCON*         A  -VARIABLE-  CONSTANT  TO  BE  USED  AS  A  FL.PT.  NUMBER    AST  120 

C         **ROW, COLUMN**      A  WORKSHEET  ENTRY  TO  BE  TRUNCATED  AND  USED  AS  INTAST  130 

C         *ROW, COLUMN*         A  WORKSHEET  ENTRY  TO  BE  USED  AS  FLOATING  POINT      AST  140 

C  AST  150 
C         NONBLA  IS  A  FUNCTION  WHICH  RETURNS  THE  NEXT  NON-BLANK  CHARACTER      AST  160 

C         IN  THE  CARD  AND  ALSO  POINTS  M  AT  IT  AST  170 

C  AST  180 

C              KARG  =  1,  SINGLE  *.    KARG  =  0,  DOUBLE  *.  AST  190 

C  AST  200 

L=KARG  AST  210 

K=NONBLA(M)  AST  220 

IF  (K.NE.40)  GO  TO  20  AST  230 

C  AST  240 

C         A  LONG  LINE  OF  ASTERISKS  FOUND,  SKIP  OVER  THEM  AND  IGNORE  AST  250 

C  AST  260 

KARG=7  AST  270 

10        M=M+1  AST  280 

IF  (KARD(M)-40)  100,10,100  AST  290 

20        IF  (K.GE.36)  GO  TO  60  AST  300 

IF  (K.GE.10)  GO  TO  40  AST  310 

C  AST  320 

C         NUMBER  IS  FIRST  NON-BLANK  CHARACTER,  SET  N  =  COMMA  AST  330 

C  AST  340 

N=43  AST  350 

30        CALL  AARGS  AST  360 

IF  (KARG.NE.O)  GO  TO  60  AST  370 

IF  (NONBLA (M) .EQ .N)  IF  (N-40)  35,37,35  AST  375 

GO  TO  60  AST  380 

35        IF  (NONBLA (M+l ) .GE. 10)  GO  TO  60  AST  390 

C  AST  400 

C         SET  N  =  ASTERISK  AST  410 

C  AST  420 

N=40  AST  430 

T=ARG  AST  440 

GO  TO  30  AST  450 

37        ARG2=ARG  AST  460 

ARG=T  AST  470 

KARG=5  AST  480 

GO  TO  90  AST  490 

C  AST  500 

C         LETTER  FOUND  FIRST  AST  510 

C  AST  520 

40        CALL  NNAME  (NAM(l) )  AST  530 

CALL  PHYCON  (NAM(l) )  AST  540 

IF  (ARG.EQ.O.)  GO  TO  50  AST  550 

C  AST  560 

C         PHYSICAL  CONSTANT  FOUND,  SET  KARG  =  1  AST  570 

C  AST  580 
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KAKb=l 

ACT 
Ab  1 

370 

ir      /  1    \      A  A     A  A  OA 

1 r    (L )  60,60,80 

ACT 
Ab  1 

L  A  A 

600 

c 

ACT 

Ab  1 

/  1  A 

610 

c 

Al  A  MC    Mf»T    TM    D  U  V  C  T  r-  A  1     rflMCTAMT    1  ICT       TDV    WADI  ADI  C 
NAMt   NU  1    IN   rniblLAL   LUIMblANI    Llbl  ,    IKY    V AK  1 ADLt 

1  T  CT 

Llol 

ACT 
Ab  1 

A  1  A 

6  a0 

c 

ACT 
fli  1 

A  1  A 

630 

50 

AAII      \/ADPAM     /MAM/1 \\ 

LALL  VAKLUN  (NAM(l)) 

ACT 
Ab  1 

L  A  A 

640 

rr     /AD/*    Al  C    A     \     r*  A    Trt  7A 

lr    (AKb.Nt.0.)   bU    IU  70 

ACT 
Ab  1 

A  C  A 

630 

l  n 

60 

KAKb=l 

ACT 
Ab  1 

AAA 

660 

DCTI IDM 
Kt 1 UKN 

ACT 
Ab  1 

A  7  A 

6  /  U 

7  A 

70 

If"  A  DP  1 

ACT 
Ab  1 

A  Q  A 

6oU 

80 

tr     fiintiQI  >  >U)     M C    Af\\    Ct\    TA  Art 

lr    (IMUIMdLA(M)  .  IMt  .  4U  )    bU    IU  60 

ACT 
Ab  1 

AAA 

6  V0 

A  A 

vo 

M=M+1 

ACT 
Ab  1 

7  A  A 

700 

t 

ACT 
Ab  1 

7  1  A 

710 

L 

PUCPV    TUAT    TUC    Ml  1MB  CD    AC    ACTTD1CI/C    AT    TUC    run  AC 

L-ntL-K   1  HA  1    IHt  NUNlbtK  Ur  AbltKlbKb  Al    1  hit  tNU  Ur 

TUC  CVDDCCCTAM 

1 nt  tArKtbblUN 

ACT 
Ab  1 

7  1  A 

7  ^0 

TC    TUC    CAMf    AC    AT    TUC    DCTTKIMTKir       1      (\    MCAMC    t  1 
10    1  nil   b  AMt   A  j   Al     Int.   Dtb  1 NN 1  Nb  .    L  =  U    Nit  AN  b    L,  L= 

1    MtANb  1 

ACT 
Ab  1 

75(1 

L 

ACT 
Ab  1 

7  il  A 

740 

TC      /  1      M  C     A\      TC      /l/ADh  rkl\     >IA\     QC     A  A  OC 

lr    (L.Nt.0)    lr    (KAKU (M) -40 )  73,60,73 

ACT 
Ab  1 

7  /!  C 

743 

TC     / 1/  A  D  n  /  M  \    MC    /in    AD    V  ADD  /  U  i  I  \    cn    /in  \    rn    jn  /a 
1  r    (IsAKU  (Wl)  .Nt.4U.UK.KAKU  (M+l  )  .  tU.  .  41)  )    bU    1  U  60 

ACT 
Ab  1 

7  C  A 
/  30 

7  3 

NI=IVI+1 

ACT 
Ab  1 

7  A  A 

/  6U 

KAKb=l\AKb+L 

ACT 
Ab  1 

7  7  A 
/  /  0 

1  A  A 

100 

DrTIIDII 

RETURN 

ACT 

AST 

780 

END 

AST 
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SI  IRRnilT  T  NF  RFGTN 

BEG 

U  L  \J 

10 

VPRCinN     R   on           RFGTN  R/15/70 

BEG 

20 

COMMON   /RIOPKA/  MODE  M  KARD(8H   KARG  ARG  ARG2  NEWCD(80)  KRDEND 

BEG 

30 

P 0 MMO N    /  R 1  0  P  K  F  /   N A MP ( 4 ^    11    1  ?  TSRFLG 

L» U IflmU If      /  DLUvlXL  /      If  H If  IL  \f  )   ,  L  1  ,  Lt  ,  1JI\I  Lu 

BEG 

40 

POMMflN    /RlflPKR/  NSTMT  NSTMTX  NSTMTH  NCOM  LCOM  I0VFL  C0M(2000} 

L<  \J  IfllVIU  If      /  DLvwIND  /      11 J  1  llll         J  1  III  1  A         J  Mil  1  II  (  lluvl*l  (  L  vvlll  /  i  v  *  1   I—  ,  O  v  III  ^  t  U  U  U  J 

BEG 

50 

COMMON  /BLOCRC/  NRC , RC ( 12600 ) 

BEG 

60 

COMMON  /BL0CKD /  IARGS(IOO) ,KIND(100) ,ARGTAB (100 ) , NRMAX , NR0W , NC0L , NBEG 

70 

1ARGS  VWXYZ(8)  NERR0R 

BEG 

80 

DIMENSION  ARGS(IOO) 

U  1  lilLIU  1  vll     ni\\J  J  \  A.  \J  \J  i 

BEG 

90 

EQUIVALENCE   (ARGS(l)  RC(12501U 

BEG 

100 

c 

BEG 

110 

XIV 

r 

THIS  SUBROUTINE  CONTAINS  THE  CODING  FOR  BEGIN  AND  SCAN 

BEG 

120 

JL  (L.  U 

r 
\j 

BEG 

140 

IF  (L2  EQ  1)  GO  TO  20 

BEG 

150 

r 

BEG 

160 

r 

V/ 

SCAN     (CARD  UP  TO  AND  INCLUDING  CARD  COLUMN  ++  ) 

BEG 

170 

IF  (NARGS.GT.l)  CALL  ERROR  (221) 

BEG 

X  o  w 

IF  (NARGS .GE . 1 .AND . KIND (1 ) . EQ . 0 . AND . I ARGS ( 1 ) .GE . 6 . AND . IARGS (1 ) 

LE  .BEG 

190 

180)  GO  TO  10 

BEG 

200 

L  V  V 

K=205 

BEG 

210 

GO  TO  30 

BEG 

220 

1  u 

KRDEND=IARGS (1) 

BEG 

?  30 

GO  TO  40 

BEG 

240 

c 

BEG 

250 

c 

BEGIN  STORING  INSTRUCTIONS  AT  NUMBER  ++ 

BEG 

260 

r 

IF  NO  NUMBER  IS  GIVEN    1  IS  ASSUMED 

BEG 

270 

x.  I  W 

r 

w 

BEG 

&=  "J>  V 

?o 

IF  (MODE . EQ . 1 )  GO  TO  50 

BEG 

790 

b  7  v 

K=5 

BEG 

100 

CALL  ERROR  (K) 

BEG 

310 

40 

RETURN 

BEG 

320 

R0 

IF  (NARGS-1)  70  90  60 

BEG 

^  u 

AO 

K=10 

BEG 

"T  w 

GO  TO  30 

BEG 

350 

ji  J>  %s 

70 

NSTMT=0 

BEG 

360 

fin 

M0DE=3 

BEG 

?  7  0 

GO  TO  40 

BEG 

o  y 

Q0 

TF    ^  K  TNn  M  '\    FO  O*   tlfl  TO  100 

REG 

j  i\j 

K=20 

BEG 

400 

GO  TO  30 

BEG 

4 1 0 

"V  JL  W 

i  on 

IF  (IARGS(l) .GT.0. AND. IARGS(l) .LT. 1000)  GO  TO  110 

BEG 

420 

■T  fc  W 

K=7 

BEG 

410 

GO  TO  30 

BEG 

4  4  0 

1 1  n 

NSTMT=10*(IARGS(1)-1) 

BEG 

31  U 

GO  TO  80 

BEG 

Hs  Q  U 

END 

BEG 

470 
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CllDDAIlT  1  MC     nr   III      /  T  C  T     D     *7  \ 

SUBROUIINc  dcJN    ( lb  1  , K  gL) 

D  C  1 

BEJ 

10 

c 

wrnf  t ah       c     a  a                nr  i  m  c/tt/ta 

VERSION     5.00          BEJN  5/15/70 

a  r*  i 

BEJ 

20 

c 

t  r"    TfT    a       r1  n  t  a  v/    t  c    i~  a  n    or  mi 

IF  IST=0     ENTRY   IS  FOR  BEJN 

BEJ 

30 

c 

tc    TCT    t       riiTOU    TC    rnn  nriii 

IF   I5T=1     tNIRY   IS  rOK  BtlN 

D  C  1 

BEJ 

A  A 

40 

a t  nr nr  t  Am    n  /  i  \ 

DIMENSION  R(l) 

D  C  1 

BEJ 

50 

HAIIDI   T     ADCATCTAM     V     D     "7     A     D     A     A     C     C     A     A     A  \J 

DOUBLE  PRECISION  X , R , Z , A , B , C , D , E , F , G , P , Q , Y 

BEJ 

60 

V/       T       A  A 

Y=l . DO 

D  C  1 

BEJ 

~T  A 

70 

tc    /tct   Kir    a  \    \/      i  nn 
lr    (lbl.Nt.0)  Y=-1.00 

D  C  1 

BcJ 

O  A 

80 

X  =  Z 

D  C  1 

DC  J 

A  A 

90 

AA      T  A     M      1       1  A  A 

DU  10  N=l ,100 

D  C  1 
DCJ 

1  A  A 

100 

10 

A  /  hi  \       A  A 

R (N )=0 . 0 

n  r  i 

BEJ 

110 

1    A  A 

LA=0 

D  C  1 

BEJ 

120 

TC      /V     1  C     Z.  A     \     rn    TA     *3  A 

IF    ( X  .  Lt . 60 . )   bU    I U  30 

D  C  1 

BEJ 

1  O  A 

130 

1    A  1 

LA=1 

D  C  1 

BEJ 

140 

TC      /V     IC     1  A  A      \      A  A     TA  OA 

lr    (X.Lt.100.)   bU   1  U  20 

D  C  1 

BEJ 

1  C  A 

150 

AAI 1       CODAD      /  1  a  c  \ 

CALL  tKKOK    ( 225 ) 

a  r"  i 

BEJ 

160 

A  A     T  A      1  1  A 

bU    IU  130 

D  C  1 

DCJ 

1  T  A 

170 

A 

V     V  /  1     A  A 
A=A /  2  .  UO 

D  C  1 

BLJ 

1  O  A 

180 

1 a 
30 

A     V  /  *>     A  A 

A=X / 2 . UO 

D  C  1 

DCJ 

1  A  A 

190 

TC      /V     AT     IC     \     A  A     TA     1  A  A 

lr    (X.bl.15.)    bU    IU  100 

D  C  1 

DC  J 

*>  A  A 

200 

D      1       A  A 

B=l . 00 

D  C  1 

BEJ 

A  1  A 

210 

O     1  HA 

L=l . 00 

D  C  1 

BEJ 

AAA 

220 

rV  A      /I  A     Kl      T       1  A  A 

UO  40  N=l ,100 

D  C  1 

BEJ 

A  O  A 

230 

1  M 

J  =N 

D  C  1 

DC.  J 

">  A  A 

240 

B=B  A/L 

D  C  1 
DC.  J 

OCA 

250 

A      A      1       A  A 

C=C+1 . DO 

D  C  1 

BEJ 

A  /  A 

260 

TC      /  D     IT         C  A     ■}  A  \     AA     TA  CA 

IF   (B .LT . .50-30)  GU  TU  50 

D  C  1 

BEJ 

270 

40 

PAilTTHIIC 

LUN 1 INUc 

D  C  1 

DCJ 

AAA 

280 

c  a 

50 

A     D  *  A   /  A 

D=D  A / U 

D  C  1 

BEJ 

AAA 

290 

A      A  *  *  O 

A=A**2 

D  C  1 

BEJ 

O  A  A 

300 

1/      V      Z.      A  A 

K=X+6 . DO 

D  C  1 

BEJ 

1  1  A 

310 

C  1/ 

c=K 

D  C  1 

BEJ 

1  A  A 

320 

C     1/  .  1 

BtJ 

330 

A     C.I      A  A 

b=r+l . 00 

D  C  1 

BtJ 

340 

d   i    n  a 
r=l . 00 

DC  1 
btJ 

"3  C  A 

350 

A      1       A  A 

0=1 . DO 

D  C  1 

BEJ 

">  /  A 

360 

DO  60  N=1,K 

D  C  i 

BEJ 

OTA 

370 

A     1      AA  D*A//C*C\*\/ 

r=l . D0-r*A/ (c*r  )  * Y 

A      1      AA  A*A//fT*Av*W 

Q=1.D0-QA/(EG)Y 

□  C  1 

BtJ 

O  A  A 

380 

D  C  1 

BtJ 

A  A 

390 

C      C      1      A  A 

E=E-1 . DO 

DC  1 

BtJ 

400 

P      C      1      A  A 

F=F-1 . DO 

DC  1 

BtJ 

A  1  A 

410 

/  A 

60 

A     A     1      A  A 

G=G-1 . DO 

DC  1 

BtJ 

/tin 

4Z0 

D  /   1      1  \      D  *  A 

R ( J+l )=B  r 

DC  1 

BtJ 

430 

A  /    1      A  \  AAA 

R (J+2 )=D*Q 

□  C  1 

BtJ 

440 

70 

A  A        A  A        hi        1  1 

DO  80  N=l , J 

D  C  1 

BEJ 

450 

K=J -N+l 

D  C  1 

BEJ 

a  /  n 

460 

A  1/ 

A=K 

DC  1 

BtJ 

Jl  7  A 

4/0 

O  A 

80 

R(K)=2.D0A*R(K+1) /X-R (K+2 ) *Y 

D  C  1 

BtJ 

480 

T  ^       /I    A       r*  A      A\       AA      TA      "1  A 

IF  (LA.EQ.0)  GO  TO  130 

BEJ 

AAA 

490 

1   A     1   A  1 

LA=LA-1 

DC  1 

BtJ 

C  A  A 

A      D/l \£D/1AA\ 

A=R ( 1 )   R  ( 100 ) 

DC  1 

BtJ 

CIA 

510 

D  AAA 

B= . 0D0 

BEJ 

C  O  A 

520 

A  A       AA       hi       ^  AA 

DO  90  N=l,99 

D  C  1 

BEJ 

r  *i  A 

530 

1/        1  A  A  Al 

K=100-N 

DC  1 

BtJ 

C  Jl  A 

540 

A      A     D/AI     1   \  *  D  /  1/  \ 

A=A+R (N+l ) *R (K ) 

D  C  1 

BtJ 

CCA 

550 

90 

D     D  D/AI\#D/l/\ 

B=B+R (N) *R (K) 

D  C  1 

BtJ 

C  £  A 

560 

1  AO 

J=98 

DC  1 

BtJ 

C  7  A 

570 

D  /  1  A  A  \  A 

K ( 100 )=A 

DC  1 

BtJ 

C  O  A 

580 

R(99)=B 

BEJ 

590 

28 


100 


110 


120 
130 


x=z 

BEJ 

600 

GO  TO  70 

BEJ 

610 

K=l .5*X 

BEJ 

620 

B=l .DO 

BEJ 

630 

C=K 

BEJ 

640 

DO  110  N=1,K 

BEJ 

650 

B=A*B/C 

BEJ 

660 

C=C-1 .DO 

BEJ 

670 

P=2 .D-9 

BEJ 

680 

IF   (LA.EQ.l)  P=5.D-20 

BEJ 

690 

C=K+1 

BEJ 

700 

DO  120  N=l,30 

BEJ 

710 

J=K+N 

BEJ 

720 

B=B*A/C 

BEJ 

730 

C=C+1 .DO 

BEJ 

740 

IF  (B.LT.P)  GO  TO  50 

BEJ 

750 

IF  (J.EQ.98)  GO  TO  50 

BEJ 

760 

CONTINUE 

BEJ 

770 

GO  TO  50 

BEJ 

780 

RETURN 

BEJ 

790 

END 

BEJ 

800 
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SUBROUTINE  BESSEL 

VERSION    5.00         BESSEL  5/15/70 

COMMON  /BLOCKD /  IARGS(IOO) , KIND (100) ,ARGTAB(100) ,NRMAX ,NROW(NCOL 
1ARGS,VWXYZ(8) ,NERROR 
COMMON  /BLOCRC/  NRC  ,  RC ( 12600 ) 
EQUIVALENCE  (ARGS ( 1 ), RC ( 12501 ) ) 
DIMENSION  ARGS(IOO) 
COMMON  /SCRAT/  NS ,NS2  ,A  (13500 ) 

DOUBLE  PRECISION  DBEJ , X , Y , E , P ,Q , S , T , BINTJO ,COMELL , Z , DXEX , XEX 

DOUBLE  PRECISION  FDCOS,FDEXP 

DOUBLE  PRECISION  AA ( 1000 ), B ( 1000 ), W( 100 ) 

EQUIVALENCE  (A(1),AA),   (A(2001),B),  (A(4001),W) 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG 

DIMENSION  R(l)  ,  IA(1) ,  KI (1) 


EQUIVALENCE  (R,RC),   (IA,  IARGS) 
COMMON  /ABEKI /  X,Y,P,Q,S,T 
DOUBLE  PRECISION  DSNCOS,DXEXP 
COMMON  /CONSLB/  XTRIG,XEXP 
COMMON  /DCONLB/  DSNCOS,DXEXP 


(KI ,KIND) ,   (NR ,NRMAX) 


WJG  PATCH 


)())()()())()()()()  ()()()()()()()()() 


XEX=XEXP-3.0 

DXEX=DXEXP-4.0D0 

IF  (NARGS.GE.2)  GO  TO  10 

CALL  ERROR  (10) 

RETURN 


END  PATCH 


)()()()()()()()()())()()()()() 


IF  (L2.GT.28)  GO  TO  250 
N=0 

=L2/2 

=2*L 

F  (L.EQ.L2)  N=l 
F  (L2.GT.12)  GO  TO  110 
F  (NARGS.GT.2)  CALL  ERROR  (10) 
CALL  ADRESS  (NARGS , J ) 
F  (J.LE.O)  CALL  ERROR  (11) 
T=l 

F  (KI (1) .EQ.l)  GO  TO  20 
CALL  ADRESS  (1,JA) 

F  (JA.LE.O)  CALL  ERROR  (11) 

T=2 
M=l 

(NERROR.NE.O)  RETURN 
(L2.GT.2)  M=5 
(L2.GT.4)  M=3 
(L2.GT.6)  M=7 
(L2.GT.8)  M=3 
(L2.GT.10)  M=7 


F 
F 
F 
F 
F 
F 
=0 

F  (L2.GT.4)  L=l 
F  (L2.GT.8)  L=2 
F  (LT.EQ.l)  GO  TO  70 

DO  50  1=1, NR 

X=R(JA) 
A=JA+1 
=1  .DO 


BES 
BES 
,NBES 
BES 
BES 
BES 
BES 
BES 
BES 


10 
20 
30 
40 
50 
60 
70 
80 
90 


BES  100 
BES  110 
BES  120 
BES  130 
BES  140 
BES  150 
BES  160 
BES  170 
BES  180 
BES  190 
BES  200 
BES  210 
BES  220 
BES  225 
BES  227 
BES  230 
BES  240 
BES  250 
BES  260 
BES  270 
BES  280 
BES  290 
BES  300 
BES  310 
BES  320 
BES  330 
BES  340 
BES  350 
BES  360 
BES  370 
BES  380 
BES  390 
BES  400 
BES  410 
BES  420 
BES  430 
BES  440 
BES  450 
BES  460 
BES  470 
BES  480 
BES  490 
BES  500 
BES  510 
BES  520 
BES  530 
BES  540 
BES  550 
BES  560 
BES  570 


30 


c 
c 
c 
c 
c 
c 

30 


33 
35 


C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 

40 
50 
60 
70 


C 

80 


C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 

90 


IF  (L.EQ.O)  GO  TO  33  BES  580 

IF  (L.EQ.2)  GO  TO  30  BES  590 

IF(DABS(X) .LT.XEX)     GO  TO  33  BES  600 

IF    1X1     IS  GREATER  THAN  XEXP    AND  LESS  THAN  DXEXP  THE  RESULTS        BES  610 

WILL  BE  SCALED  BY  EXP  (X)  OR  EXP(-X).  BES  620 

IF    1X1  IS  GREATER  THAN  DXEXP  THE  SUBROUTINE  DBEJ  DOES  THE  SCALINGBES  630 


GO  TO  33 


IF (X)  35,35,40 


AND  A  MESSAGE  IS  PRINTED. 

THIS  APPLIES  TO  THE  FOLLOWING  COMMANDS  BIZERO 
BKONE 

CALL  ERROR  (105) 
IF  (DABS(X) .GT.DXEX) 
Y=FDEXP(X) 

IF  (M.EQ.-3)  Y=1.D0/Y 
IF  (M.EQ.5.0R.M.EQ.7) 
GO  TO  40 
R(J)=0. 

CALL  ERROR  (101) 
GO  TO  50 

L2=1,M=1,N=0,LT=2,L=0 
L2=2,M=1,N=1,LT=2,L=0 
L2=3,M=5,N=0,LT=2,L=0 
L2=4,M=5,N=1,LT=2,L=0 
L2=5,M=3,N=0,LT=2,L=1 
L2=6,M=3,N=1,LT=2,L=1 
L2=7,M=7,N=0,LT=2,L=1 
L2=8,M=7,N=1,LT=2,L=1 
L2=9,M=3,N=0,LT=2,L=2 
L2=10,M=3,N=1,LT=2,L=2 
L2=11,M=7,N=0,LT=2,L=2 
L2=12 ,M=7 ,N=1 ,LT=2 ,L=2 
R(J)=Y*DBEJ (X,N,M) 
J=J+1 
RETURN 
X=ARGS(1) 
Y=1.D0 

IF  (L.EQ.O)  GO  TO  90 
IF  (L.EQ.2)  GO  TO  80 
IF  (DABS(X) .LT.XEX)     GO  TO  90 
SEE  COMMENTS  ABOVE  ON  BOUNDS  OF 
CALL  ERROR  (105) 
IF  (DABS(X) .GT.DXEX)     GO  TO  90 
Y=FDEXP(X) 

IF  (M.EQ.3)  Y=1.D0/Y 
L2=1,M=1,N=0,LT=1,L=0 
L2=2,M=1,N=1  LT=1,L=0 
L2=3,M=5,N=0,LT=1,L=0 
L2=4,M=5,N=1,LT=1 ,L=0 
L2=5,M=3,N=0,LT=1,L=1 
L2=6,M=3,N=1,LT=1,L=1 
L2=6,M=3,N=1,LT=1,L=1 
L2=7,M=7,N=0,LT=1,L=1 
L2=8,M=7,N=1,LT=1,L=1 
L2=9,M=3,N=0,LT=1,L=2 
L2=10,M=3,N=1,LT=1,L=2 
L2=11,M=7,N=0,LT=1,L=2 
L2=12,M=7,N=1,LT=1,L=2 
X=Y*DBEJ(X,N,M) 
DO  100  1=1, NR 
R(J)=X 


BIONE ,  BKZERO 


X  BEFORE  DBEJ  IS  CALLED 


BJZERO  OF  **  STORE  IN  ++ 
: BJONE    OF  **  STORE  IN  ++ 


BYZERO  OF  **  STORE 
BYONE  OF  **  STORE 
BIZERO  OF  **  STORE 
BIONE  OF  **  SOTRE 
BIONE  OF  **  STORE 
BKZERO  OF  **  SOTRE 
BKONE  OF  **  STORE 
EXIZERO  OF  **  STORE 
EXIONE  OF  ** 
EXKZERO  OF  ** 
EXKONE  OF 


*  * 


STORE 
STORE 
STORE 


IN 
IN 
IN 
IN 
IN 
IN 
IN 
IN 
IN 
IN 
IN 


++ 
++ 
++ 
++ 
++ 
++ 
++ 
++ 
++ 
++ 
++ 


BES  640 
BES  650 
BES  660 
BES  670 
BES  680 
BES  690 
BES  700 
BES  705 
BES  710 
BES  720 
BES  730 
BES  740 


: BJZERO  OF  ++ 

STORE 

IN 

++ 

BES 

:BJONE    OF  ++ 

STORE 

IN 

++ 

BES 

: BYZERO  OF  ++ 

STORE 

IN 

++ 

BES 

: BYONE    OF  ++ 

STORE 

IN 

++ 

BES 

:BIZERO  OF  ++ 

STORE 

IN 

++ 

BES 

:BIONE    OF  ++ 

STORE 

IN 

++ 

BES 

: BKZERO  OF  ++ 

SOTRE 

IN 

++ 

BES 

: BKONE    OF  ++ 

STORE 

IN 

++ 

BES 

:EXJZERO  OF  ++ 

STORE 

IN 

++ 

BES 

:EXIONE    OF  ++ 

STORE 

IN 

++ 

BES 

:EXKZERO  OF  ++ 

STORE 

IN 

++ 

BES 

: EXKONE    OF  ++ 

STORE 

IN 

++ 

BES 

BES  870 
BES  880 
BES  890 
BES  900 
BES  910 
BES  920 
BES  930 
BES  940 
BES  950 
BES  960 
BES  970 
BES  980 
BES  990 
BES1000 
BES1010 
BES1020 
BES1030 
BES1040 
BES1050 
BES1060 
BES1070 
BES1080 
BES1090 
BES1100 
BES1110 
BES1120 
BES1130 
BES1140 
BES1150 
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100  J=J+1 

GO  TO  60 
110      IF  (L2.GT.20)  GO  TO  210 

IF  (NARGS.GT.3)  CALL  ERROR  (10) 

M=l 

IF  (L2.GT.14)  M=2 
IF  (L2.GT.16)  M=l 
IF  (L2.GT.18)  M=2 
L=0 

IF  (L2.GT.16)  L=l 
Y=.785398163397D0 
LV=0 
JX=0 

120      CALL  ADRESS  (NARGS , J2) 

IF  (J2.LE.0)  CALL  ERROR  (11) 
CALL  ADRESS  (NARGS-1J1) 
IF  (Jl.LE.O)  CALL  ERROR  (11) 
LT=0 

IF  (KI (1) .EQ.l)  GO  TO  130 
CALL  ADRESS  (1,JA) 
IF  (JA.LE.O)  CALL  ERROR  (11) 
LT=1 
130  K=0 
KA=0 

IF  (LT+LV.EQ.O)  GO  TO  200 
IF  (LV.EQ.O)  GO  TO  230 
IF  (LT.EQ.O)  GO  TO  240 
140      IF  (NERROR.NE.O)  RETURN 
DO  190  1=1 ,NRMAX 
IF  (KA.EQ.O)  X=R(JA) 
JA=JA+1 
E=1.D0 

IF  (JX.NE.O)  Y=R(JB) 
JB=JB+1 

L2=15,M=2,N=0,L=0 
L2=16,M=2,N=1,L=0 
L2=19,M=2,N=0,L=1 
L2=20 ,M=2,N=1,L=1 
L2=23 ,M=2 ,N=0 ,L=0 

L2=24,7=2 ,N=1 ,L=0 
L2=27 ,M=2 ,N=0 ,L=1 
L2=28,M=2,N=1,L=1 
IF  (M.EQ.2)  CALL  CBEK 
L2=13 ,M=1 ,N=0 (L=0 
L2=14,M=1,N=1,L=0 
L2=18 ,M=1 ,N=1 ,L=1 
L2=21 ,M=1 ,N=0 ,L=0 
L2=22 ,M=18N=1 ,L=0 
L2=25,M=1,N=0,L=1 
L2=26,M=1,N=1 ,L=1 
IF  (M.EQ.l)  CALL  CBEI 
Z=X*FDCOS(Y) 
IF  (L.EQ.l)  GO  TO  150 
IF  (DABS(Z) .LT.XEX)     GO  TO  160 
CALL  ERROR  (105) 
150  E=FDEXP(Z) 

IF  (M.EQ.l)  E=1.D0/E 
160      IF  (N.EQ.O)  GO  TO  170 

C         STORE  INTO  WORK  SHEET  RESULTS  OF  COMMANDS  KBIONE,  KBKONE 


C 
C 
C 
C 
C 
C 
C 
C 

C 
C 
C 
C 
C 
C 
C 


KBKZERO  OF  $$  PUT  REAL  IN  ++  IMAGINARY  ++ 

KBKONE  OF  $$  PUT  REAL  IN  ++  IMAGINARY  ++ 
KEXKZR  OF  $$  PUT  REAL  IN  ++  IMAGINARY  ++ 

KEXKONE  OF  $$  PUT  REAL  IN  ++  IMAGINARY  ++ 

CKZERO    OF  $$  OHI  $$  UT  REAL  ++  I  MAG  ++ 

CKONE      OF  $$  PHI  $$  PUT  REAL  ++    IMAG  ++ 

CEKZERO  OF  $$  PHI  $$  PUT  REAL  ++    IMAG  ++ 

CEKONE    OF  $$  PHI  $$  PUT  REAL  ++    IMAG  ++ 

KBIZERO  OF  $$  PUT  REAL  IN  ++  IMAGINARY  ++ 
KBIONE  OF  $$  PUT  REAL  IN  ++  IMAGINARY  ++ 
KEXIONE  OF  $$  PUT  REAL  IN  ++  IMAGINARY  ++ 
CIZERO  OF  $$  PHI  $$  PUT  REAL  ++  IMAG  ++ 
CIONE  OF  $  PHI  $  PUT  REAL  ++  IMAG  ++ 
CEIZERO  OF  $$  HI  $  UT  REAL  ++  IMAG  ++ 

CEIONE    OF  $$  PHI  $$  PUT  REAL  ++    IMAG  ++ 


BES1160 
BES1170 
BES1180 
BES1190 
BES1200 
BES1210 
BES1220 
BES1230 
BES1240 
BES1250 
BES1260 
BES1270 
BES1280 
BES1290 
BES1300 
BES1310 
BES1320 
BES1330 
BES1340 
BES1350 
BES1360 
BES1370 
BES1380 
BES1390 
BES1400 
BES1410 
BES1420 
BES1430 
BES1440 
BES1450 
BES1460 
BES1470 
BES1480 
BES1490 
BES1500 
BES1510 
BES1520 
BES1530 
BES1540 
BES1550 
BES1560 
BES1570 
BES1580 
BES1590 
BES1600 
BES1610 
BES1620 
BES1630 
BES1640 
BES1650 
BES1660 
BES1670 
BES1680 
BES1690 
BES1700 
BES1710 
BES1720 
BES1730 
BES1740 
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c 

KEXIONE,  1 

<EXK0NE,  CIONE,  CEIONE, 

^  r  i/  a  1 1  r 

CEKONE 

BES1750 

R (J1)=E*S 

BES1760 

R (J2)=E*T 

BES1770 

GO  TO  180 

BES1780 

c 

STORE  INTO  WORK  SHEET  RESULTS  OF 

COMMANDS  KBIZERO,  KBKZERO, 

BES1790 

c 

KEXIZER,  1 

/CVI/7CD        nTirnrt               T  7CDH 

\EXKZtK ,   L1ZLKU ,  LLlZtKU 

r  i/  7  r  n  n 

,  CEKZERO 

pi  P"  f  i  ft  ft  ft 

BES1800 

170 

R (J  1 )=h*P 

BEbl810 

R  ( J2 )=t  Q 

pi  P*  tf"  ^  n  ft  ft 

BES1820 

180 

J 1=J 1+1 

n  r"  f  i  a  *}  a 

BES1830 

190 

J2=J2+1 

BES1840 

nrTiinu 

RETURN 

BES1850 

200 

IF  (JX.EQ 

A  \       A  A      T  f\      O  A  rt 

.0)  GO  TO  240 

Btbl860 

v/      a  p»  a  p*  /  f\  \ 

Y=ARGS (2 ) 

D  C  C  1  OTA 

BEbl8 7 0 

X=ARGS ( 1 ) 

BES1880 

KA=1 

n  p*  a  t  ft  ft.  /\ 

BES1890 

JX=0 

ft  r~  ft  ^  ft  ft  ft 

BES1900 

GO  TO  140 

BES1910 

210 

IF  (NARGS 

.GT.4)  CALL  ERROR  (10) 

BES1920 

JX=1 

P\  P*  P"  ^  ft  ft  ft 

BES1930 

LV=0 

BE51940 

IF  (KI  (2) 

.EQ.l)  GO  TO  220 

BES1950 

CALL  ADRESS  (2  ,  JB) 

A  P"  P*  i  ft  y  « 

BES1960 

IF  (JB.LE 

.0)  CALL  ERROR  (11) 

PI  P"  P"  ^    ft  ^  ft 

BES1970 

LV=1 

pi  r~  A  ^  a  ft  ft 

BES1980 

220 

M=l 

nr  f i  aaa 

BES1990 

IF  (L2.GT 

.22)  M=2 

BES2000 

IF  (L2.GT 

.24)  M=l 

BES2010 

IF  (L2.GT 

.26)  M=2 

BES2020 

L=0 

BES2030 

IF  (L2.GT 

.24)  L=l 

ft  ^  ft  ft  J-\    M  ft 

BES2040 

GO  TO  120 

n  P"  A  ft  ft  p  ft 

BES2050 

230 

IF  (JX.EQ 

.0)  GO  TO  140 

PI  I"1  f*  ft.  A  /  A 

BES2060 

Y=ARGS(2) 

BES2070 

JX=0 

BES2080 

GO  TO  140 

PI  P  p  «  ft  A  ft 

BES2090 

240 

KA=1 

BES2100 

X=ARGS(1) 

p*  ft  ^  ^  ft 

BES2110 

GO  TO  140 

a  p-  p1  ft  *i  ft  ft 

BES2120 

250 

IF  (L2.GT 

.32)  GO  TO  350 

a  p-  p*  ft  ^  ft  ft 

BES2130 

260 

IF  (NARGS 

.GT.2)  CALL  ERROR  (10) 

pi  r  p  ft  i  *  ft 

BES2140 

CALL  ADRESS  (NARGS, J) 

BES2150 

IF  (J.LE.i 

3)  CALL  ERROR  (11) 

BES2160 

LT=0 

p*  f-  p*  ft  ^  ^  ft 

BES2170 

IF  (KI  (1) 

.EQ.l)  GO  TO  270 

a  p*  p*  ft  ^  ft  ft 

BES2180 

CALL  ADRESS  (1,JA) 

pi  p*  f  ft  i  ft  ft 

BES2190 

IF  (JA.LE 

.0)  CALL  ERROR  (11) 

BES2200 

LT=1 

r\  P  P  ft  ft  i  ft 

BES2210 

270 

IF  (NERROR.NE.O)  RETURN 

pi  p"  p1  ft  ft  ft  ft 

BES2220 

IF  (LT.EQ 

.0)  X=ARGS(1) 

p*  a  a  a  a 

BES2230 

IF  (L2.GT 

.37)  GO  TO  310 

p>  p"  p*  ft  ft  j  ft 

BES2240 

IF  (L2.EQ 

.32)  GO  TO  310 

O  P*  P"  ft  ft  p  pi 

BE52250 

IF  (L2.GT 

.29)  GO  TO  290 

BES2260 

DO  280  N= 

L  ,NR 

pi  p*  p*  ft  ft  ^  ft 

BES2270 

IF  (LT.EQ 

.1)  X=R(JA) 

BES2280 

JA=JA+1 

BES2290 

A 

C 

L2=29 

:INTJ0  OF 

$$  STORE  IN  ++ 

nrPfti ft  ft 

BES2300 

R(J)=BINTJO(X,W,Z) 

BES2310 

280 

J=J+1 

BES2320 

RETURN 

BES2330 

33 


290 

K=l 

n  r  r  i  1  >i  r\ 

BES2340 

T  C     /  1  a    rrt     i  i  \     1/  o 

IF    ( L2 . bU. . 3 1 )  K=2 

BES2350 

DU  300  N=l , NK 

D  C  C  O  ^  L  rt 

BE52360 

T  C      /IT     Crt     1  \      V     D  /   1  A  \ 

IF    (LT.bQ.l)  X=K(JA) 

BES2370 

JA=JA+1 

opp i i nn 

BES2380 

C 

L2=30,K=1                         :  ELLIPTICAL  FIRST  OF 

$$ 

STORE  IN  ++ 

D  C*  P  *1  *5  Art 

BES2390 

0 

L2=31,K=2                         :  ELLIPTICAL  SECOND  OF  $! 

$  STORE  IN  ++ 

DLTCOil  Art 

R  t  1  )-P0MELL (X  K) 

D  C  C  1  VI  1  A 

dtb24 10 

"5  A  A 

300 

J  — J  +  X 

Dtb2420 

RFTIIRN 

□  tr  c  o  >i  i  n 
Btb243  0 

310 

TF    M  T   FO    "M    PAN    FRROR  0(\\ 

1  r      ^  L  1  .         .  1  )     l/WLL    Cr\  i\U  r\     \  c.\J  ) 

DPP  1  ^  A  rt 

Bbb2440 

i_  A 

D  C  C  1  A  C  A 

Bto2450 

K— MR 

BtbZ460 

if       i f  inn)  go  to  33n 

Btb2470 

K— i  on 

IN —  A  U  U 

Bhb2480 

1  a—  i  j.  l  no 

T~\  t~  C         A  rt  rt 

BES2490 

DO  320   I-K  MR 

n  r  c  i  r  rt  rt 

BES2500 

R ( JA)=Q  0 

BES2510 

ion 
3<:0 

JA-JA+l 

Btb2520 

p 

L2=32                                    BESJN  X-  ** 

STORE 

I N  . 

X  11 

rt 

DtbZ530 

o  ^  a 
330 

IF   f 12  E0  32)   CALL  BEJN   (0  W  Z) 

DTP  O  C  J(  A 

p 

L2-38                                      BESTN     X-  ** 

STORE 

TN 

1  I* 

Tt 

ore i c  c  rt 

IF   (L2  E0  38)   CALL  BEJN   (1  W  Z) 

D  LT  C  O  C  L  rt 

IF    (L2  E0  39)   GO  TO  460 

btbZ570 

DO  340  N-l  K 

R  <  U-W(N) 

D  C  C      C  A  A 

BEb2590 

340 

J-J+l 

D  C  C  O  Z  rt  A 

BES2600 

RETURN 

i\  l.  i  \j  i\  n 

QPPn/  T  rt 

3  50 

TF    (\  7  GT  34)   GO  TO  390 

D  (~  C  1  Z  OA 

Btb2620 

L=NR 

BtbZ630 

TF    (NR  GT  1000)  1—1000 

QPPO  /  yi  A 

BLb2640 

TF    fNARGS  GT  ?)   PAI  1    FRROR  M0) 

Utb2650 

CALL  ADRESS   (NARGS  J) 

BLb2660 

IF    M  LE  0)   PALL  ERROR  HI) 

DtbZo / 0 

TF    fKTd)    FO   1)   PAN    FRROR  f?n) 

DtbiOoO 

PAI  1    ADRF^    ( 1    1 A ) 

btbZ690 

TF    MA   IF    m    P  Al  1     FPPOP    Ml  \ 

D  C  C  O  7  A  A 
btb2700 

TF    rNFRROR  NF  0)  RFTIIRN 

btb2710 

TF    CI  ?   FO   33)    GO  TO  %f\(\ 

Dtb2720 

p 

17—34                                        -7FR0^  R  I7FR0 

I  u 

I  N 

++ 

a  m  n  i  j_ 

Mill/  ++ 

D  C  C  O  7  "2  A 

bbbZ / 30 

PAI 1     RF70WF    /AA   R    l    1 \ 

bbb2740 

p n    TP    \ 7 il 

D  C  C  o  ^  c  n 

bbb2750 

C 

19—33                                        .7FR0<;  R  IONF 

J  1  UI\L 

T  N 

++ 

Awn  i  _L 

MIlU     +  + 

bbbZ760 

360 

PAI 1    RF7FRO    / AA  R   1  M 

IMLL    DC£.Ht\U     \  MM  ,  D  ,  1  ,  L  ) 

Bbb2770 

"3  7  A 
3/0 

no  3fto  N— i  i 

DC  C  O  7  Q A 
DC OC 1 OU 

P  M A \_AA  \ 
tl  (  J  M  )  =MM  ^  n  ) 

DF  C  O  7  Q  A 

bbbZ /V0 

K  ( J  )=D  (IM  ) 

D  C  C  O  O  A  A 

bbbZoOO 

1  A—  1  A  i  1 
J  H=J  M  +  l 

orcooi a 
bbb2810 

380 

1— 

bbb2820 

PFTI IPM 
KL 1  URN 

D  C  C  O  O  1  ft 

bbb2o30 

IF    (LZ.bl .36)    bU    1 U  430 

DC  C  O  Q  A  ft 

IF  (NARGS.GT.2)  CALL  ERROR  (10) 

D  F  C  O  Q  C  A 

bbbZobO 

CALL  ADRESS  (NARGS , J ) 

D  C  C  O  O  Z  A 

BEb2860 

IF  (J.LE.O)  CALL  ERROR  (11) 

D  C  C  O  O  T  A 

Bb52870 

LT=0 

D  C  C  O  O  O  rt 

IF  (KI (1) .EQ.l)  GO  TO  400 

DC C  O  O  Q  rt 

DC j^oVU 

CALL  ADRESS  (1,JA) 

D  C  C  o  rt  rt  rt 

BtbZVOO 

IF  (JA.LE.O)  CALL  ERROR  (11) 

n  C  C  O  A  1  A 

BES2910 

LT=1 

BES2920 
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400 

IF  (LT.EQ.O)  X=ARGS(1) 

BES2930 

IF  (NERROR  .NE  .0)  RETURN 

BES2940 

K=0 

BES2950 

IF  (L2.EQ.36)  K=l 

BES2960 

DO  420  N=1,NR 

BES2970 

IF  (LT.NE.O)  X=R(JA) 

BES2980 

JA=JA+1 

BES2990 

C 

L2=35,K=0                         :STRUVE  ZERO 

OF 

$$ 

STORE 

IN  ++ 

BES3000 

C 

L2=36,K=1                         :STRUVE  ONE 

OF 

$$ 

STORE 

IN  ++ 

BES3010 

CALL  STRUVE  (X,Y,Z,W) 

BES3020 

IF  (K.EQ.O)  GO  TO  410 

BES3030 

C 

STORE    RESULTS  FOR  STRUVE  ONE 

BES3040 

R(J)=Z 

BES3050 

GO  TO  420 

BES3060 

C 

STORE  RESULTS  OF    STRUVE  ZERO 

BES3070 

410 

R(J)=Y 

BES3080 

420 

J=J+1 

BES3090 

RETURN 

BES3100 

430 

IF  (L2.GT.37)  GO  TO  260 

BES3110 

IF  (NARGS.GT.3)  CALL  ERROR  (10) 

BES3120 

CALL  ADRESS  (NARGS , J ) 

BES3130 

IF  (J .LE.O)  CALL  ERROR  (11) 

BES3140 

IF  (KI(l).EQ.l)  CALL  ERROR  (20) 

BES3150 

CALL  ADRESS  (1,JA) 

BES3160 

IF  (JA.LE.O)  CALL  ERROR  (11) 

BES3170 

JB=IA(2) 

BES3180 

IF  (KI (2) .NE.O)  CALL  ERROR  (3) 

BES3190 

IF  (NERROR .NE  .0)  RETURN 

BES3200 

K=IA(2) 

BES3210 

LNR=NRMAX 

BES3220 

IF  (LNR .GT . 1000)  LNR=1000 

BES3230 

DO  440  N=l ,LNR 

BES3240 

A     ft      j  ft  1    t           r%     ,      t    A  i 

AA (N)=R (JA) 

BES3250 

440 

JA=JA+1 

BES3260 

C 

L2=37                               : HARMONIC  OF 

++ 

STORE 

IN  ++ 

BES3270 

CALL  FOURIA  (AA ,B ( 1 ) , B ( 2 ) ,K , L ) 

BES3280 

DO  450  N=1(JB 

BES3290 

R(J)=B(N) 

BES3300 

450 

J=J+1 

BES3310 

RETURN 

BES3320 

460 

IF  (X.LT.XEXP)  GO  TO  470 

BES3330 

CALL  ERROR  (225) 

BES3340 

RETURN 

BES3350 

C 

L2=39                               : BESKN    X=  ** 

STORE  IN 

++ 

BES3360 

470 

AA(1)=DBEJ (X,0,7) 

BES3370 

AA(2)=DBEJ (X, 1 ,7) 

BES3380 

R(J)=AA(1) 

BES3390 

R  (J+1)=AA(2) 

BES3400 

J=J+2 

BES3410 

DO  480  1=3, K 

BES3420 

Z=I-2 

BES3430 

A     A      t    9     ■            ft     A      4    V          At           a         -X-                ft     A      *    IF          *     i       J  \£ 

AA(I )=AA(I-2)+2 .*Z*AA(I-1) /X 

BES3440 

R(j)=AA(I) 

BES3450 

IF  (AA(I) .GT.3.E37)  GO  TO  490 

BES3460 

480 

J=J+1 

BES3470 

RETURN 

BES3480 

490 

DO  500  JA=I,K 

BES3490 

R(J)=0.0 

BES3500 

500 

J=J+1 

BES3510 

RETURN 

BES3520 

END 

BES3530 
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SUBROUTINE  BEZERO 

(A ,B ,M,L) 

BEZ 

10 

c 

VERSION  5.00 

BEZERO 

5/15/70 

BEZ 

20 

DOUBLE  PRECISION  A(1),B(1),X, 

Y  , 

AA  ,  AB , AC , FDSQRT 

BEZ 

30 

KB=1 

BEZ 

40 

N=M 

BEZ 

50 

10 

J=4*N-1 

BEZ 

60 

IF  (J  .GT.44)  GO  TO 

130 

BEZ 

70 

GO  TO  (20,30,40,50,60,70,80,90,100,110,120) 

,  N 

BEZ 

80 

20 

X=2 . 404825577D0 

BEZ 

90 

Y= . 5191474973D0 

BEZ 

100 

ft  f\    x  a  lift 

GO  TO  140 

BEZ 

110 

30 

V       £  rftftftTOITftOHft 

X=5 .520078110300 

BEZ 

120 

Y=- .340264806500 

BEZ 

130 

ft  A     T  A      1  A  ft 

bU   IU  140 

BEZ 

140 

40 

V      O  ZCOTftTftlftftnft 

X=8 .653727912900 

BEZ 

150 

\J  ftTlJlCftftftftftAft 

Y= . 2714522999D0 

BEZ 

160 

OA    T  A    i  a  e\ 
bU    IU  140 

BEZ 

170 

50 

X=ll .7915344391U0 

BEZ 

180 

Y=—  .  Z3Z459o31'HJ0 

BEZ 

190 

bU    IU  140 

BEZ 

200 

60 

X=14 .930917708600 

BEZ 

210 

V         *3  A  £ C  A  /  A  1  1  1  Pi  A 

Y=.Z065464331U0 

BEZ 

220 

o a  Trt  i  >!  a 
bU    IU  140 

BEZ 

230 

70 

X=lo .07106396/9L/0 

BEZ 

240 

Y=-  .  Lot  1  Zoo03L)0 

BEZ 

250 

OA     T A     1  A  A 

bU    IU  140 

BEZ 

260 

80 

X=Z 1 .Z116366Z9900 

BEZ 

270 

Y=. 173Z65894ZU0 

BEZ 

280 

OA    T A    1  A  A 

bU    IU  140 

BEZ 

290 

90 

V      *i  A  OCO>ITTCOftOr\ft 

X=Z4 .35Z47 1530800 

BEZ 

300 

Y=- .161701550700 

BEZ 

310 

OA    T A    1  A  A 

bU    IU  140 

BEZ 

320 

100 

V     IT  vlft^jl"7ft*l,3ftn.ft 

X=Z7 .49347913200 

BEZ 

330 

Y=. 152181213800 

BEZ 

340 

OA    T A    1  vl  A 

bU    IU  140 

BEZ 

350 

110 

V      Oft      /«)jt/ft  /  A  /  ft  jl  ft  ft 

X=30 . 6346064684D0 

BEZ 

360 

Y=- . 1441659777U0 

BEZ 

370 

ft  A      T  ft      i  <a 

GO  TO  140 

BEZ 

380 

120 

X=33 . 7758202136D0 

BEZ 

390 

Y= . 1372969434D0 

BEZ 

400 

GO  TO  140 

BEZ 

410 

130 

X=J 

BEZ 

420 

V     V4:i  iviirftftzcozftft 

X=X*3 .1415926536D0 

BEZ 

430 

A  A       1       ft  ft    /  V  A  A 

AA=1 . DO /X**2 

BEZ 

440 

AD       1       ft  ft      ft  ftft&AA&zl 

AB=1.D0+2.D0AA*(1 

ft  ft       A  A  Jfc    /  O  1 

.  D0-AA* (31 . 

T\  ft 

DO 

-AA* (3779  .D0- 

-AA*6277237 . DO /7 . DO ) / 

ft  r-  t 

BEZ 

450 

15  .DO)  /3  .00) 

BEZ 

460 

J=N/2 

BEZ 

470 

J=2*J 

BEZ 

480 

AC=1 .DO 

BEZ 

490 

IF  (J.EQ.N)  AC— 1. 

DO 

BEZ 

500 

Y=AC*1.595769122D0 

* (1 .D0-AA** 

2* 

56.D0/3.D0)/FDSQRT(X) 

BEZ 

510 

X=X*AB/4.00 

BEZ 

520 

140 

A(KB)=X 

BEZ 

530 

B (KB)=Y 

BEZ 

540 

N=N+1 

BEZ 

550 

KB=KB+1 

BEZ 

560 

IF  (KB.LE.L)  GO  TO 

10 

BEZ 

570 

RETURN 

BEZ 

580 

END 

BEZ 

590 

36 


SUBROUTINE  BEZONE  (A  B  M  L) 

BE0 

10 

r 

VERSION     5  00  BEZONE 

5/15/70 

BE0 

20 

DOUBLE  PRECISION  A(l)  B(l)  R 

S  T  X 

Y , FDSQRT 

BE0 

30 

KB-1 

BE0 

40 

N=M 

BEO 

50 

1  0 

j-4*N+l 

BEO 

60 

IF   (J.GT.46)  GO  TO  130 

BEO 

70 

GO  TO  (20,30,40,50,60,70,80,90,100,110 

,120)  N 

BEO 

80 

20 

X=3 .831705970200 

BEO 

90 

Y=-.4027593957D0 

BEO 

100 

GO  TO  140 

BEO 

110 

30 

X=7 .0155866698D0 

BEO 

120 

Y=.3001157525D0 

BEO 

130 

GO  TO  140 

BEO 

140 

40 

X=10 .1734681351D0 

BEO 

150 

Y=-.2497048771D0 

BEO 

160 

GO  TO  140 

BEO 

170 

50 

X=13.3236919363D0 

BEO 

180 

Y=.2183594072D0 

BEO 

190 

GO  TO  140 

BEO 

200 

60 

X=16.4706300509D0 

BEO 

210 

Y=-.1964653715D0 

BEO 

220 

GO  TO  140 

BEO 

230 

70 

X=19.6158585105D0 

BEO 

240 

Y=.180063375D0 

BEO 

250 

GO  TO  140 

BEO 

260 

80 

X=22 .7600843806D0 

BEO 

270 

Y=-.1671846005D0 

BEO 

280 

GO  TO  140 

BEO 

290 

90 

X=25.9036720876D0 

BEO 

300 

Y=.1567249863D0 

BEO 

310 

GO  TO  140 

BEO 

320 

100 

X=29 .046828534900 

BEO 

330 

Y=-.1480111100D0 

BEO 

340 

GO  TO  140 

BEO 

350 

110 

X=32.1896799110D0 

BEO 

360 

Y=.1406057982D0 

BEO 

370 

GO  TO  140 

BEO 

380 

120 

X=35 .332307550100 

BEO 

390 

Y=-.1342112403D0 

BEO 

400 

GO  TO  140 

BEO 

410 

130 

X=J 

BEO 

420 

X=X*3 .1415926536D0 

BEO 

430 

R=l .00/X**2 

BEO 

440 

S=l .00-6 .D0*R* (1 .D0-R* (1 .00- 

R* (157  . 

2D0 

-130080  .6D0*R/7 .DO) ) ) 

BEO 

450 

J=N/2 

BEO 

460 

J=2*J 

BEO 

470 

T=l .DO 

BEO 

U  Im.  V 

480 

w  \J 

IF  (J  NE  N)  T=-l  DO 

BEO 

490 

Y=T* 1.595769 122D0* (1 .D0+R**2 

*24.D0* 

(1. 

DO-81 . 6D0*R) ) /FDSQRT (X) 

BEO 

500 

X=S*X/4.D0 

BEO 

510 

140 

A(KB)=X 

BEO 

520 

B (KB)=Y 

BEO 

530 

J  J  V 

N=N+1 

BEO 

540 

KB=KB+1 

BEO 

550 

IF  (KB.LE.L)  GO  TO  10 

BEO 

560 

RETURN 

BEO 

570 

END 

BEO 

580 

37 


FUNCTION  dINIJU   ( X  #  A ,L ) 

DTM 

BIN 

10 

wrilC  T  AM         C     A  A                   □  T  M  T  1  A                   C  /  1  C  /  7  A 

VERblON     5.00           dINIJU  5/15/70 

D  T  Al 
BIN 

O  A 

20 

a  t  tar*  kl  f  T  A  M     A  /  1  \ 

DIMENSION  A(l) 

D  T  Al 
BIN 

1  ft 

30 

DAIIDI  C    DDCPTCTAM    D  T  KIT  lf\    A    7    Y    D    f    HOC  1 

UUUDLt  rKtLlblUlM  D i IM 1 JU , A , L  , A , D , L , Dot J 

DTM 
D  1  IM 

A  ft 

IU 

Z=DABS (X) 

D  T  Al 
BIN 

C  A 

50 

T  FT      /  7     AT     1  A  A      \     AA     TA  OA 

IF    (Z . ti 1  . 100  .  )   tiU   1  U  20 

D  T  Al 
BIN 

L  A 

60 

AAli      nr  ui     /n     A    7  \ 

CALL  BEJN  (0,A,Z) 

O  T  Al 

BIN 

1  A 

70 

IE      i  7    AT     Z.  A     \     AA    TA     1  A 

IF    (Z .til  .60  .  )   tiU   IU  30 

D  T  Al 
BIN 

O  A 

80 

n       n  r\  a 
D= . 000 

D  T  Al 
BIN 

Q  A 
70 

A,  A     1  A     Al     O     1  A  A  O 

UU    10  N=Z , 10U , Z 

DTM 

Din 

1  AA 
1UU 

B=B+A (N ) 

D  T  Al 

BIN 

1  1  A 

110 

n      O     A  A  *  O 

B=2 . D0*B 

D  T  Al 
BIN 

1  1  A 

120 

A  A    TA     A  A 
tiU     IU  40 

D  1  f\ 

A  /  1  \     noc  1  /  7    A     1  \ 

A ( 1 )=UBtJ (Z  ,  0  , 1 ) 

DTM 
D  1 IM 

1  A  ft 

A  /  *)  \     AO  C  1  /  7     1      1  \ 

A ( 2 ) =DBt  J (L , 1 , 1) 

DTM 
D  J.  IM 

15U 

L=l . U0 /Z  Z 

DTM 
DIN 

1  L  ft 

loU 

D      1       AA      A  /  **»  \  Jfc  /  1       AA     A5k/TI      AA     A  *  /  A      AA     A  Jfc  /  O  *>  C 

B=l .  D0+A ( 2 )    (1 .  D0-L    (1 .  D0-L    (9 .  D0-L  (225 

AA     A  *  *1  1  A  1  C  AA\\\\ 

.  D0-L  1 1025  .  U0 ) ) ) ) 

D  T  Al 
BIN 

1  1  ft 

170 

0=1 .  UU-L    \5  . UU— L    (45 . UU-L    (15/5 . UU -772  23 

•DO  L) ) ) 

DTM 
D  I  IM 

loU 

B=B-A (1 ) *C/£ 

D  T  Al 
BIN 

1  O  A 

190 

D  T  AIT  lt\  D 
D  1  N  1  J  (J=D 

D  T  Al 
BIN 

O  A  A 

200 

RETURN 

BIN 

210 

END 

BIN 

220 

38 


c 
c 
c 
c 
c 
c 
c 
c 
c 
c 


c 
c 


10 


20 


30 


40 


50 
60 


70 

80 
90 


SUBROUTINE  BJORCK  (X,B,NP,A,F)  BJO 
VERSION    5.00         BJORCK         5/15/70  BJO 
INPUT  IS  X,B  AND  NP .  BJO 
OUTPUT  IS  F.  BJO 
THIS  SUBROUTINE  WAS  ADAPTED  BY  ROY  H.  WAMPLER  AND  M.  STUART  SCOTT, BJO 
NATIONAL  BUREAU  OF  STANDARDS,  WASHINGTON,  D .  C . ,  JULY  1969,  FROM  BJO 
A  SUBROUTINE  CALLED  'BJORCK'  WHICH  WAS  WRITTEN  BY  WILLIAM  J.  HALL, BJO 
NATIONAL  BUREAU  OF  STANDARDS,  BOULDER,  COL.     THIS  ROUTINE  USES  THEBJO 
MODIFIED  GRAM-SCHMIDT  ALGORITHM  GIVEN  BY  AKE  BJORCK  IN  'SOLVING 
LINEAR  LEAST  SQUARES  PROBLEMS  BY  GRAM-SCHMIDT  ORTHOGONAL  I ZAT I ON' 
'BIT'  VOL.  7   (1967)  ,  PAGES  1-21. 
DOUBLE  PRECISION  C , D , R , Y , FDSQRT 
DIMENSION  X(l)  ,  B(l) ,  A(3,l) 
DIMENSION  C(3,3),  D(3),  R(3),  Y(4) 

INITIALIZE  A  AND  FORM  SUM  OF  SQUARES  OF  THE  B  VECTOR 
Y(4)=0.D0 
DO  10  1=1, NP 
A(1,I)=1.0 
A(2,I)=X(I) 
A(3,I)=X(I)*X(I) 
Y(4)=Y(4)+B(I)*B(I) 
NF=3 

D(1)=0.D0 
Y(1)=0.D0 
DO  20  1=1, NP 
D(1)=A(1,I)*A(1,I)+D(1) 
Y(1)=A(1,I)*B(I)+Y(1) 
Y(1)=Y(1)/D(1) 
IR=0 

DO  60  K=2,NF 
DO  40  J=K,NF 
IR=IR+1 
R(IR)=O.DO 
DO  30  1=1, NP 

R(IR)=A(K-1,I)*A(J,I)+R(IR) 
R(IR)=R(IR) /D(K-l) 
DO  40  1=1, NP 

A(J,I)=A(J,I)-A(K-1,I)*R(IR) 
D(K)=O.DO 
Y(K)=O.DO 
DO  50  1=1, NP 

B(I)=B(I)-A (K-1,I)*Y(K-1) 
Y(K)=A(K,I)*B(I)+Y(K) 
D(K)=A(K,I)*A(K,I)+D(K) 
Y(K)=Y(K)/D(K) 
IRS=-NF 
DO  90  K=1,NF 
IRS=IRS+NF-K+1 
IR=IRS 

DO  90  JJ=1,K 
J=K-JJ+1 
C(K,J)=Y(J) 
IF  (JJ-1)  90,90,70 
DO  80  1=2, JJ 

C(K(J)=C(K,J)-C(K,K-I+2)*R(IR) 
IR=IR-1 
IR=IR_NF+K 
DO  100  1=1, NF 


10 
20 
30 
40 
50 
60 
70 
80 

BJO  90 
BJO  100 
BJO  110 
BJO  115 
BJO  120 
BJO  130 
BJO  140 
BJO  150 
BJO  160 
BJO  170 
BJO  180 
BJO  190 
BJO  200 
BJO  210 
BJO  220 
BJO  230 
BJO  240 
BJO  250 
BJO  260 
BJO  270 
BJO  280 
BJO  290 
BJO  300 
BJO  310 
BJO  320 
BJO  330 
BJO  340 
BJO  350 
BJO  360 
BJO  370 
BJO  380 
BJO  390 
BJO  400 
BJO  410 
BJO  420 
BJO  430 
BJO  440 
BJO  450 
BJO  460 
BJO  470 
BJO  480 
BJO  490 
BJO  500 
BJO  510 
BJO  520 
BJO  530 
BJO  540 
BJO  550 
BJO  560 
BJO  570 
BJO  580 


39 


100      Y(I)=Y(I)*FDSQRT(D(I) )  BJO  590 

F=Y(3)*Y(3)*FL0AT(NP-3) / (Y (4)-Y (1 j *Y (1 )-Y (2 ) *Y (2 )-Y  (3 ) *Y  (3 ) )  BJO  600 

RETURN  BJO  610 

END  BJO  620 


40 


C         BLOCK  DATA    BLOCK  BLO  10 

C         VERSION     5.00          BLOCK           5/15/70  BLO  20 

BLOCK    DATA  BLO  30 

COMMON  /  ABCDEF  /  L (  48  )  BLO  40 

COMMON /HEADER /NOCARD (80 ) ,ITLE(60,6) , LNCNT , I  PR  I  NT ,NPAGE , I  PUNCH  BLO  50 

COMMON /FMAT/ I FMTX (  6 ) , IOSWT , IFMTS (  6),LHEAD(96)  BLO  60 

C         BLOCK  BLO  70 

C                   ABCDEF  BLO  80 

C                                  L(l)  =1H0  L(2)  =1H1  L(3)  =1H2  L(4)  =1H3  L(5)  =1H4  BLO  90 

C                                  L(6)  =1H5  L(7)  =1H6  L(8)  =1H7  L(9)  =1H8  L(10)=1H9  BLO  100 

C                                  L(11)=1HA  L(12)=1HB  L(13)=1HC  L(1J)=1HD  L(15)=1HE  BLO  110 

C                                 L(16)=1HF  L(17)=1HG  L(18)=1HH  L(19)=1HI  L(20)=1HJ  BLO  120 

C                                 L(21)=1HK  L(22)=1HL  L(23)=1HM  L(24)=1HN  L(25)=1H0  BLO  130 

C                                  L(26)=1HP  L(27)=1HQ  L(28)/1HR  L(29)=1HS  L(30)=1HT  BLO  140 

C                                  L(31)=1HU  L(32)=1HV  L(33)=1HW  L(34)=1HX  L(35)=1HY  BLO  150 

C                                  L(36)=1HZ  L(37)=1H/  L(38)=1H.  L(39)=1H-  L(40)=1H+  BLO  160 

C                                  L(41)=1H*  L(42)=2H(  L(43)=1H)  L(44)=1H,  L(45)=1H  BLO  170 

C                                  L(46)  =  1H=  L(47)=1H$  (  48)=1H/  BLO  180 

DATA    L(l) ,L(2) ,L(3) ,L(4) ,L(5) ,L(6) ,L(7)  ,L(8)  ,L(9)  ,L(10)/  BLO  190 

1  1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7(1H8,1H9/  BLO  200 
DATA    L(ll) ,L(12) ,L(13) ,L(14) ,L(15) ,L(16) ,L(17)  ,L(18) ,L(19)  ,L(20)/BL0  210 

1  1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH(1HI,1HJ/  BLO  220 
DATA    L(21) ,L(22) ,L(23) ,L(24) ,L(25) ,L(26) ,L(27) ,L(28) ,L(29) ,L(30) /BLO  230 

1  1HK,1HL,1HM,1HN,1H0,1HP,1HQ,1HR,1HS,1HT/  BLO  240 
DATA    L(31) ,L(32) ,L(33) ,L (34) ,  L  (35 ) (L(36) ,  L  (37 ) ,  L  (38 ) ,L(39) ,L(40) /BLO  250 

1  1HU,1HV,1HW,1HX,1HY,1HZ,1H/,1H. ,1H-,1H+/  BLO  260 

DATA    L(41) ,L(42) ,L(13) ,L(44) ,L(45) ,L(46) ,L(47) ,L(48)/  BLO  270 

1  1H*,1H(,1H) ,1H, ,1H  ,1H=,1H$  ,1H//  BLO  280 

C         NOCARD  CONTAINS  THE  MESSAGE  WRITTEN  SAVED  FROM  THE  OMNITAB  CARD  BLO  290 

DATA  NOCARD(l) ,N0CARD(2) ,N0CARD(3) ,N0CARD(4) ,N0CARD(5) ,N0CARD(6)  ,  BLO  300 

1N0CARD(7) , NOCARD (8) , NOCARD (9) , NOCARD (10) , NOCARD (11) , NOCARD (12) ,  BLO  310 
2N0CARD(13) , NOCARD (14) , NOCARD (15) , NOCARD (16) , NOCARD (17) , NOCARD (18) ,BLO  320 
3N0CARD(19) , NOCARD (20) , NOCARD (21) , NOCARD (22) , NOCARD (23) , NOCARD (24) ,BLO  330 
4N0CARD(25) , NOCARD (26) , NOCARD (27) , NOCARD (28) , NOCARD (29) , NOCARD (30) ,BLO  340 
5N0CARD(31) (N0CARD(32) ,N0CARD(33) ,N0CARD(34) ,N0CARD(35) ,N0CARD(36) ,BLO  350 

6N0CARD(37) ,N0CARD(38) ,N0CARD(39) ,N0CARD(40) /  BLO  360 

71H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  (1H  ,1H  ,1H  ,1H  ,1H  ,  BLO  370 

81H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,  BLO  380 

9  1H  ,1H  ,1H  ,1H  ,1H0,1HM,1HN(1HI/  BLO  390 

DATA  N0CARD(41) ,N0CARD(42) ,NQCARD(43) ,N0CARD(44) ,N0CARD(45)  ,  BLO  400 

1  N0CARD(46) ,N0CARD(47) ,N0CARD(48) ,N0CARD(49) ,N0CARD(50)  ,  BLO  410 

2  N0CARD(51) ,N0CARD(52) ,N0CARD(53) ,N0CARD(54) ,N0CARD(55) ,  BLO  420 

3  N0CARD(56) ,N0CARD(57) ,N0CARD(58) ,N0CARD(59)  ,N0CARD(60)  ,  BLO  430 

4  N0CARD(61) ,N0CARD(62) ,N0CARD(63) ,N0CARD(64) ,N0CARD(65)  ,  BLO  440 

5  N0CARD(66) ,N0CARD(67) ,N0CARD(68) ,N0CARD(69) ,N0CARD(70) ,  BLO  450 

6  N0CARD(71) ,N0CARD(72) ,N0CARD(73) ,N0CARD(74) ,N0CARD(75)  ,  BLO  460 

7  N0CARD(76) ,N0CARD(77) ,N0CARD(78) ,N0CARD(79) ,N0CARD(80)/  BLO  470 
81HT,1HA,1HB(1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  , 1H  ,1H  ,1H  ,1H  ,1H  ,  BLO  480 
91H  ,1H  ,1H  ,1H  (1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  , 1H  ,1H  ,1H  ,1H  ,1H  ,  BLO  490 
A1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  /  BLO  500 

C         IFMTS  CONTAINS  FORMAT  USED  BY  PRINT  BLO  510 

DATA  IFMTS(l) , IFMTS (2) , IFMTS (3) , IFMTS (4) ,IFMTS(5) ,IFMTS(6)/  BLO  520 

1  1H(,2H1P,2H8E,3H15. ,1H6,1H)/  BLO  530 

END  BLO  540 
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CBI  600 

AA=B*G**2/A 

CBI  610 

T=T+AA*P 

CBI  620 

U=U+AA*Q 

CBI  630 

AA=C*W*H/A 

CBI  640 

V=V+AA*P 

CBI  650 

X=X+AA*Q 

CBI  660 

B=B*D*G**2/A 

CBI  670 

IF  (B.LT. .5D-10)  GO  TO  50 

CBI  680 

C=C*D*W*H/A 

CBI  690 

W=W+2.D0 

CBI  700 

G=G+2.D0 

CBI  710 

H=H+2.00 

CBI  720 

A=A+1.D0 

CBI  730 

AA=P*E-Q*F 

CBI  740 

Q=F*P+E*Q 

CBI  750 

P=AA 

CBI  760 

A=Y*T-Z*U 

CBI  770 

B=-(Y*U+T*Z) 

CBI  780 

C=Y*V-Z*X 

CBI  790 

D=-(Y*X+Z*V) 

CBI  800 

RETURN 

CBI  810 

END 
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SUBROUTINE  CBEK 
C         VERSION    5.00         CBEK  5/15/70 

C  COMPUTES  KO(Z)  AND  K1(Z)  FOR  COMPLEX  ARGUMENT  Z=R*E(IS) 

COMMON  /ABEKI /  R,S,A,B,C,D 
DOUBLE  PRECISION  A,B,C,D,R,S 

DOUBLE  PRECISION  E , F ,G ,H , P ,Q ,T ,U , V , W,X , Y , Z , AA (40 ) , AB (40 ) , AC , AD , AE 

DOUBLE  PRECISION  FDLOG  , FDCOS , FDEXP , FDSIN , FDSQRT 

COMMON  /SCRAT/  NS  ,NS2 , SCRAT (13500 ) 

EQUIVALENCE  (SCRAT (1700) ,AA) ,   (SCRAT (1800) ,AB) 

IF  (R.LE.O.O)  GO  TO  80 

E=FDCOS(S) 

F=FDSIN(S) 

IF  (R.GT.8.)  GO  TO  40 
P=l .DO-2 .D0*F**2 
Q=2.D0*E*F 
W=P 
Z=Q 

X=(R/2 .D0)**2 
Y=X 
V=X 

G=E*(4.D0*E**2-3.D0) 
H=F*(3.D0-4.D0*F**2) 
T=FDL0G(R/2 . DO ) + . 5772156649D0 
A=-T 
B=-S 

C=E*(T-0.5D0)-S*F 
U=F*(T-0.5D0)+S*E 
AC=1.D0 
AD=2.D0 
AA(1)=1.D0 
AB(1)=1 .25D0 
DO  10  N=2,40 
AE-N 

AA(N)=AA(N-1)+1.D0/AE 
10        AB(N)=AA(N)+1.D0/(2.D0*(AE+1.D0) ) 
DO  20  N=l,40 
AE=T-AA (N) 
D=P*AE-S*Q 
AE=Q*AE+S*P 
A=A-D*X/AC**2 
B=B-AE*X/AC**2 
AE=T-AB(N) 
D=G*AE-H*S 
AE=H*AE+G*S 
C=C+D*Y/(AC*AD) 
U=U+AE*Y/(AC*AD) 
X=X*V/AC**2 

IF  (X.LT. .5D-10)  GO  TO  30 
Y=Y*V/(AC*AD) 
AC=AC+1.D0 
AD=AD+1.00 
AE=P 

P=AE*W-Q*Z 
Q=Q*W+AE*Z 
AE-G 

G=AE*W-H*Z 
20  H=H*W+AE*Z 
30  C=E/R+R*C/2.D0 

D=-F/R+R*U/2.D0 


CBK 
CBK 
CBK 
CBK 
CBK 
CBK 
CBK 
CBK 
CBK 


10 
20 
30 
40 
50 
60 
70 
80 
90 


CBK  100 
CBK  110 
CBK  120 
CBK  130 
CBK  140 
CBK  150 
CBK  160 
CBK  170 
CBK  180 
CBK  190 
CBK  200 
CBK  210 
CBK  220 
CBK  230 
CBK  240 
CBK  250 
CBK  260 
CBK  270 
CBK  280 
CBK  290 
CBK  300 
CBK  310 
CBK  320 
CBK  330 
CBK  340 
CBK  350 
CBK  360 
CBK  370 
CBK  380 
CBK  390 
CBK  400 
CBK  410 
CBK  420 
CBK  430 
CBK  440 
CBK  450 
CBK  460 
CBK  470 
CBK  480 
CBK  490 
CBK  500 
CBK  510 
CBK  520 
CBK  530 
CBK  540 
CBK  550 
CBK  560 
CBK  570 
CBK  580 
CBK  590 
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GO  TO  70 

CBK  600 

U=FOEXP(-R*E)*FDSQRT (1 .570796326800 /R) 

CBK  610 

V=R*F+S/2 .DO 

CBK  620 

Y=U*FDCOS (V) 

CBK  630 

7-ll*FDSIN  (\M 

CBK  640 

W—  1  DO 

CBK  650 

G-l  DO 

CBK  660 

u_i  no 

n — j  *  v  \j 

CBK  670 

P=E 

CBK  680 

0=F 

CBK  690 

T-l  DO 

CBK  700 

CBK  710 

V=l . DO 

CBK  720 

X=0 . DO 

CBK  730 

A=l .DO 

CBK  740 

B— 1  DO / (8  D0*R) 

CBK  750 

C-B 

CBK  760 

D=B 

CBK  770 

AC=-1 .DO 

CBK  780 

DO  50  N=l,12 

CBK  790 

AD=AC*B*G**2/A 

CBK  800 

AE=AC*C*W*H/A 

CBK  810 

T=T+AD*P 

CBK  820 

U=U-AD*Q 

CBK  830 

V=V+AE*P 

CBK  840 

X=X-AE*Q 

CBK  850 

AD=B 

CBK  860 

B=B*D*G**2/A 

CBK  870 

IF  (B.GT.AD)  GO  TO  60 

CBK  880 

IF  (B.LT. .5D-10)  GO  TO  60 

CBK  890 

C=C*D*W*H/A 

CBK  900 

W=W+2 .DO 

CBK  910 

H=H+2 .DO 

CBK  920 

G=G+2 .DO 

CBK  930 

A=A+1 .DO 

CBK  940 

AC=-1  D0*AC 

CBK  950 

AD=P 

CBK  960 

P=AD*E-Q*F 

CBK  970 

Q=Q*E+AD*F 

CBK  980 

A=Y*T+U*Z 

CBK  990 

B=Y*U-T*Z 

CBK1000 

C=Y*V+X*Z 

CBK1010 

D=Y*X-V*Z 

CBK1020 

RETURN 

CBK1030 

A=0  DO 

CBK1040 

B=-  785398163397D0 

CBK1050 

C-0  DO 

CBK1060 

D=0 .DO 

CBK1070 

CALL  ERROR  (101) 

vnLL     Lit  IWI»       \  X  V  A  J 

CBK1080 

RETURN 

CBK1090 

END 

CBK1100 

409-118  OL  -  71  -  4 
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SUBROUTINE  CHANGE  CHA  10 

C         VERSION    5.00         CHANGE         5/15/70  CHA  20 

C  CHA  30 

C         CHANGE  SIGNS  OF  COLS  ++,  ++,  ++,  ETC.  CHA  40 

C  CHA  50 

COMMON  /BLOCRC/  NRC ,RC (12600)  CHA  60 
COMMON  /BLOCKD /  IARGS ( 100 ), KIND ( 100 ) ,ARGTAB (100 ), NRMAX , NROW, NCOL , NCHA  70 

1ARGS , VWXYZ (8 ) ,NERROR  CHA  80 

DIMENSION  ARGS(IOO)  CHA  90 

EQUIVALENCE  (ARGS (1) ,RC  (12501) )  CHA  100 

IF  (NARGS)  50,50,10  CHA  110 

10        DO  30  1=1, NARGS  CHA  120 

CALL  ADRESS  (I, J)  CHA  130 

IF   (J)  40,60,20  CHA  140 

20        IF  (NERROR.NE.O)  RETURN  CHA  150 

DO  30  N=l , NRMAX  CHA  160 

JJ=J+N-1  CHA  170 

30        RC(JJ)=-RC(JJ)  CHA  180 

GO  TO  70  CHA  190 

40        CALL  ERROR  (3)  CHA  200 

GO  TO  70  CHA  210 

50        CALL  ERROR  (10)  CHA  220 

GO  TO  70  CHA  230 

60        CALL  ERROR  (11)  CHA  240 

70        RETURN  CHA  250 

END  CHA  260 


SUBROUTINE  CHKCOL  (J)  CHK  10 

C         VERSION    5.00         CHKCOL         5/15/70  CHK  20 

COMMON  /BLOCRC/  NRC,RC(12600)  CHK  30 

COMMON  /BLOCKD/  IARGS (100) ,KIND (100) ,ARGTAB (100) , NRMAX , NROW, NCOL ,NCHK  40 

IARGS ,VWXYZ (8) ,NERROR  CHK  50 

DIMENSION  ARGS(IOO)  CHK  60 

EQUIVALENCE  (ARGS  (1) ,RC  (12501) )  CHK  70 

C  CHK  80 

C                THIS  ROUTINE  CHECKS  THAT  ALL  /NARGS/  ARGUMENTS  ARE  LEGAL           CHK  90 

C                COLUMN  NUMBERS  AND  CONVERTS  THEM  IN  IARGS  TO  THEIR  BEGINNING    CHK  100 

C                ADDRESSES.  CHK  110 

IF  (NARGS. GT.O)  GO  TO  20  CHK  120 

10        J=l  CHK  130 

GO  TO  40  CHK  140 

20        DO  30  I=1,NARGS  CHK  150 

CALL  ADRESS  (I, IARGS (I))  CHK  160 

IF  (IARGS(I) .LE.O)  GO  TO  10  CHK  170 

30        CONTINUE  CHK  180 

J=0  CHK  190 

40        RETURN  CHK  200 

END  CHK  210 
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SUBROUTINE  CKIND  (J) 

CKI 

10 

c 

VERSION    5.00         CKIND  5/15/70 

CKI 

20 

c 

CKIND 

CKI 

30 

c 

S  PEAVY  5/22/67 

CKI 

40 

c 

THE  FIRST  J  VALUES  OF  KIND  ARE  CHECKED 

CKI 

50 

c 

IF  ALL  ARE  =0  THEN  J=0 

CKI 

60 

c 

IF  ALL  ARE  =1  THEN  J=l 

CKI 

70 

c 

IF  SOME  ARE  0  AND  SOME  1  J=2 

CKI 

80 

COMMON  /BLOCRC/  NRC , RC ( 12600 ) 

CKI 

90 

COMMON  /BLOCKD/  IARGS(IOO) ,KIND(100) ,ARGTAB (100 ) , NRMAX ,NROW,NCOL ,NCKI 

100 

1ARGS,VWXYZ(8) ,NERROR 

CKI 

110 

DIMENSION  ARGS(IOO) 

CKI 

120 

EQUIVALENCE  (ARGS (1 ), RC (12501 ) ) 

CKI 

130 

JA=J 

CKI 

140 

J=0 

CKI 

150 

DO  10  1=1, JA 

CKI 

160 

IF  (KIND ( I ) .NE.O)  GO  TO  20 

CKI 

170 

10 

CONTINUE 

CKI 

180 

RETURN 

CKI 

190 

20 

J=l 

CKI 

200 

DO  30  1=1 , JA 

CKI 

210 

IF  (KIND(I) .NE.l)  GO  TO  40 

CKI 

220 

30 

CONTINUE 

CKI 

230 

RETURN 

CKI 

240 

40 

J=2 

CKI 

250 

RETURN 

CKI 

260 

END 

CKI 

270 

SUBROUTINE  CMPARA  (XI ,X2,X3 ,Y1 ,Y2 ,Y3 ,X,Y)  CMP  10 

C         VERSION    5.00         CMPARA         5/15/70  CMP  20 

C         PROGRAM  CMPARA    WRITTEN  BY    MRS.  CARLA  MESSINA    NBS-NSRDS  JUNE  68  CMP  30 

C         CMPARA    IS  USED  BY  THE  INSTRUCTION  MAXMIN  IN  PROGRAM  CMSEPA  CMP  40 

A=( (Y2-Y3)*(X2-X1)-(Y2-Y1)* (X2-X3) ) / ( (X2-X1 ) * (X2**2-X3**2 )- (X2-X3 )CMP  50 

1*  (X2**2-X1**2) )  CMP  60 

B=((Y2-Y1)-A*(X2**2-X1**2))/(X2-X1)  CMP  70 

C=-A*X3**2-B*X3+Y3  CMP  80 

X=-B/(2.*A)  CMP  90 

Y=A*X**2+B*X+C  CMP  100 

RETURN  CMP  110 

END  CMP  120 
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SUBROUTINE  CMSEPA  CMS  10 

C         VERSION    5.00         CMSEPA  5/15/70                                                   CMS  20 

COMMON  /BLOCRC/  NRC  , RC  ( 12600 )  CMS  30 

COMMON  /BLOCKD/  I ARGS ( 100 ), KIND ( 100 ) ,ARGTAB ( 100 ), NRMAX , NROW, NCOL , NCMS  40 

1ARGS , VWXYZ (8 ) ,NERROR  CMS  50 

DIMENSION  ARGS(IOO)  CMS  60 

EQUIVALENCE  (ARGS (1) ,RC (12501) )  CMS  70 

COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG  CMS  80 

COMMON  /SCRAT/  NS  ,NS2  , A  (13500 )  CMS  90 

C         L2=2    SEPARATE  FROM  COL  ++  EVERY  ,  ,  ROW  START  WITH  ROW       STORE  INCMS  100 

C         L2=3    INSERT  IN  COL  ++  FROM  COL  ++  AT  EVERY  ,,  ROW  STARTING  AS        CMS  120 

C                       STORE  IN  COL  ++  CMS  130 

C         L2=4    MAXMIN  X  IN  ++  Y  IN  ++ ,  XMAX  IN  ++  YMAX  IN  ++,  XMIN  ++  YMIN  CMS  140 

C         PROGRAM  CMSEPA    WRITTEN  BY  MRS.  CARLA  MESSINA    NBS-NSRDS  JUNE  196CMS  150 

GO  TO  (10,10,30,310),  L2  CMS  160 

10        NARGS=NARGS+1  CMS  170 

J=NARGS  CMS  180 

DO  20  I=2,NARGS  CMS  190 

IARGS(J)=IARGS(J-1)  CMS  200 

KIND(J)=KIND(J-1)  CMS  210 

20        J=J-1  CMS  220 

30        CALL  CKIND  (J)  CMS  230 

IF   (J)  40,70,40  CMS  240 

40        K=3  CMS  250 

50        CALL  ERROR  (K)  CMS  260 

60        RETURN  CMS  270 

70        IF  (NARGS-5)  80,100,80  CMS  280 

80        K=10  CMS  290 

IF  (L2-2)  90,90,50  CMS  300 

90        NARGS=NARGS-1  CMS  310 

GO  TO  50  CMS  320 

100      M=IARGS(3)  CMS  330 

N=IARGS(4)  CMS  340 

DO  120  1=3,4  CMS  350 

IF  (IARGS (I ) )  130,130,110  CMS  360 

110      IF  (IARGS(I)-NROW)  120,120,130  CMS  370 

120      IARGS ( I )=IARGS (1 )  CMS  380 

CALL  CHKCOL  (J)  CMS  390 

IF  (J)  40,140,40  CMS  400 

130      K=16  CMS  410 

GO  TO  50  CMS  420 

140      IF  (NERROR.NE.O)  GO  TO  60  CMS  430 

IF  (NRMAX)  150,150,160  CMS  440 

150      K=9  CMS  450 

GO  TO  50  CMS  460 

160      DO  170  I=1,NARGS  CMS  470 

170      IARGS ( I )=IARGS ( I ) -1  CMS  480 

L=IARGS(5)  CMS  490 

IF  (L2-2)  180,180,210  CMS  500 

C         SEPARATE  CMS  510 

180      DO  190  1=1 , NRMAX  CMS  520 

J=IARGS(1)+I  CMS  530 

190      A(I)=RC(J)  CMS  540 

DO  200  K=N, NRMAX, M  CMS  550 

L=L+1  CMS  560 

200      RC(L)=A(K)  CMS  570 

GO  TO  60  CMS  580 

C         INSERT  CMS  590 

210      M=M-1  CMS  600 
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IF   (M)  130,130,220 
220  N=N-1 

IF  (N)  130,130,230 
230  KA=0 

I=IARGS(1) 

DO  240  K=1,N 

1=1+1 

KA=KA+1 
240  A(KA)=RC(I) 

NN=KA+IARGS (1) 

MM=IARGS(2) 

DO  260  K=N , NRMAX , M 

KA=KA+1 

MM=MM+1 

A (KA)=RC (MM) 

DO  250  LL=1,M 

KA=KA+1 

NN=NN+1 
250      A (KA)=RC (NN) 
260  CONTINUE 

I=(NRMAX-N) /M+l 

IF   (I+NRMAX-NROW)  270,270,280 
270  NRMAX=NRMAX+I 

GO  TO  290 
280  NRMAX=NROW 

CALL  ERROR  (219) 
290      DO  300  K=l, NRMAX 

L=L+1 
300  RC(L)=A(K) 

GO  TO  60 
310      IF  (NARGS-6 )  80,320,80 
320      CALL  CHKCOL  (J) 

IF   (J)  40,330,40 
330      IF  (NERROR.NE.O)  GO  TO  60 

KA=0 

IUP=-1 

IF  (NRMAX)  150,150,340 
340      IF   (NRMAX-2)  350,350,390 
350      IF   (KA)  370,370,360 
360      CALL  ERROR  (220) 
370      IF   (IUP)  380,60,60 
380  K=219 

GO  TO  50 
390      DO  400  K=l, NRMAX 

I=IARGS(1)+K-1 

J=IARGS(2)+K-1 

A(K)=RC(I) 

K2=K+NRMAX 
400  A(K2)=RC(J) 

I1=IARGS(3)-1 

J1=IARGS(4)-1 

K1=IARGS(5)-1 

L1=IARGS(6)-1 

IF   (NRMAX-4)  410,520,520 
410  K2=NRMAX+1 

IF  (A(K2)-A(K2+1) )  420,380,430 
420      IF  (A(K2+l)-A(K2+2) )  380,380,440 
430      IF  (A(K2+l)-A(K2+2) )  450,380,380 
440  IUP=IUP+1 


CMS  610 
CMS  620 
CMS  630 
CMS  640 
CMS  650 
CMS  660 
CMS  670 
CMS  680 
CMS  690 
CMS  700 
CMS  710 
CMS  720 
CMS  730 
CMS  740 
CMS  750 
CMS  760 
CMS  770 
CMS  780 
CMS  790 
CMS  800 
CMS  810 
CMS  820 
CMS  830 
CMS  840 
CMS  850 
CMS  860 
CMS  870 
CMS  880 
CMS  890 
CMS  900 
CMS  910 
CMS  920 
CMS  930 
CMS  940 
CMS  950 
CMS  960 
CMS  970 
CMS  980 
CMS  990 
CMS1000 
CMS1010 
CMS1020 
CMS1030 
CMS1040 
CMS1050 
CMS1060 
CMS1070 
CMS1080 
CMS1090 
CMS1100 
CMS1110 
CMS1120 
CMS1130 
CMS1140 
CMS1150 
CMS1160 
CMS1170 
CMS1180 
CMS1190 
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450 

T  1  ID     T  1  ID  .  1 

1 Ur=iUr+l 

A  MC  7  O  A  A 

b  Mo  1 Z  0  0 

tr      /  A  /  1  \     A  /  9  \  \     /I  A  A     A  Q  A     /I  in 

lr    (A(l)-A(Z))  460,480,460 

A  MC  7  9  7  A 

LMolZlO 

A  /  A 

4  6  0 

1  r      /  A  /  7  \     A  /  9  \  \     JI7A     JQA  ain 

lr    (A(l)-A(3))  470,480,470 

A  MC  7  9  9  A 

b  Wlj  1  z  z  0 

4  /  0 

T  C      /  A  /  9  \      k  1  1  \  \      A  A  A     Jl  OA  ilQA 

lr    (A(Z)-A(3))  490,480,490 

A  MC  7  9  5  A 

b Mb  1230 

480 

KA=1 

A  MC  7  9  /I  A 

bMblZ40 

A  A    T  A     "3  C  A 

bU    1 U  350 

A  MC  7  9  C  A 

b Mb 1250 

J3  A  A 

All  I      p  IAD  ADA      /  A  /  1  \      A  /  9  \      A  /  1  \      A  /  1/  9  \      A  /  1/  9  .  7  \      A  /  1/  9  .  9  \     VI     V  7  \ 

CALL  bMrAKA    ( A  ( 1 )  ,  A  ( 2  )  ,  A  (3  )  ,  A  (K2  )  ,  A  (K2  +  1 )  ,  A  (K2+2  )  ,  XI  ,  Y 1 ) 

A  MC  7  9  A  A 

bMblZ60 

1 r      /  T  1  !  D \     CAA     CAA  CIA 

lr    (lUr)  500,500,510 

AUC  7  9  7  A 

bMb  1 2  7  0 

500 

DP  /l/l  .  1  \  VI 

Kb (Kl+1 ) =A  i 

A  MC  7  9  O  A 

bMblZoO 

Kb(Ll+l)=Yl 

A  MC  7  9  Q  A 

bMb 1290 

A  A    T A    A A 

bO    IU  60 

A  MC  7  1  A  A 

bMb 1300 

CIA 

QA  /  T  1    .  7   \  VI 

KL ( 1 1+1 )=X1 

A  mc 111  n 
b  Mb  1 3 1 0 

Kb (Ll+1 )=Y1 

A  MC  137/1 

bMbl320 

A  A     T  A  ifl 

bU    IU  60 

A  MC  1  11/1 

bMb 1330 

c  "i  A 

520 

T     AID  AAA  V  9 

1=NKMAX-Z 

A  MC  1  1A/I 

bMb 1340 

fT^A    Tin    1/    1  T 

00   7  30  K=i , 1 

A  MC  7  1  C  A 

bMb 13 50 

T  PAH A  I  1 

1  tQUAL=l 

AMC  7  1  A  A 

bMb 1360 

Lf  o    1/  ,  MDMA  V 
KZ=K+fliKMAA 

A  MC  1  7  7(1 
bMbl i 1 U 

TC      / A / V 9 \      A  / V9  ■  1  \  \      CIA     ilft  CAA 

lr    (A (KZ ) -A (K2+1 ) )  530,610,540 

A  MC lion 
b  Mb  1 3  O  0 

E.  1  A 

TC     /  A  /  If  9  i  7  \     A  /I/O  .  A  \  \     71A    71(1  CCA 

lr    (A  (N2+1 ;  —  A  (l\2+2  )  )  /3U,/3U,550 

a Mci 7on 

b  Ifl  J  1)7U 

5  4  0 

TC       /A/1/1.  1\       A/I/O.  0\\       CIA      Tlrt      =J  A 

lr    (A (KZ+1 ) -A (KZ+Z ) )  560,730,730 

A  MC  T  A  A  A 

bMbl400 

r  a 

5  5  0 

T  1  ID  1 

iUr=l 

A  MC  l/lin 

bMbl410 

A A    T A  ETA 

bO    1 U   5  7  0 

A  MC 1  A7A 
bMb 14 20 

E  A  A 

T  1  ID  A 
1  Ur=U 

AMC  7  A1(\ 

3  /  U 

1  C      /  A  /  1/  \     A  /  If  i  7  \  \     CQn     /Art  EQA 

1 r    (A IN J  — A (K+l J )    58U ,  oUU , DoU 

AMC7  A  A  ft 

5BU 

I  r      /  A  /  V  \     A  /  V  ■  9  \  \     CAA     /  ftrt     E  Q  A 

lr    ( A  (K )  —  A  (K+Z  )  )  590,600,590 

AMC lAcn 
bMb 1450 

590 

TC       /  A   /  1/  .  1   \       A  /  1/  .  1  \  \       /OA      Z  A  A  ZQA 

lr    (A (K+l ) -A (K+Z ) )  680,600,680 

A  MC  7  A  A  A 

bMbl460 

/L  A  A 

6  0  U 

1/  A     ^  A  .  7 

KA=KA+1 

AMC  1  Jl  7  A 
bMb!4 1 0 

PA     T A     7 1 A 

bU    1 U   7  30 

A  MC  7  A  O  A 

b  Mb  1 4  8  0 

A  7  A 

oiO 

lr    ( K— 1 )  730,730,620 

A  MC  1  VI  O  A 
b  Mb  1 4  V  0 

ion 
6/0 

T  c A.1 1  A  1  "? 

A  MC  1  end 
b  Mb  1500 

TC     /  A  /  V    7\     A  /  If  \  \     ilA    /nft    /  irt 

lr    (A  (K— 1 )  —A  (K )  )  630,600,630 

A  MC  7  c  7  A 
bMbl 5 10 

63  U 

TC      1  k  1  ii     1\     A  /  If  .  7  \  \     /  >1  A     /ftft     A  yS  A 

lr    I A  (K— 1 )  —A  (K+l )  )  640,600,640 

A  MC 1  con 
bMb!52U 

4  4  A 
6>4U 

TC       /  A  /If      7   \      A  /  If  i  9  \  \      £CA      /  AA  iEA 

lr    (A  (K— 1 )  —  A  (K+Z  )  ;  650,60U,oSU 

AMC  ltlfi 

TC     1  A  f  If  9    1  \     A  /  If  9  \  \    AAA    7  7  A  ATA 
ir     (A  (K2  —  1  J  —  A  (KA  )  )    OOU  ,  OU  ,  O/U 

AMC  7  CAft 

o  (o  0 

TC      /  A  /  If  9  ■  1  \     A  /If  7  i  7  \  \     71A     7  1  A  CCA 

lr    ( A (K2+1 ) —A (KZ+Z ; )  73U,73U,55U 

A  UC  1  E  C  A 

bmo 

o  /  0 

TC      /  A  /  If  9  *  1  \     A  /If  9  •  9  \  \     CAA     77A     7  1  A 

lr    (A (KZ+1 ) — A (KZ+Z ) )  560,730,730 

AMCl CAA 
bMbl SOU 

£  ®  A 

ooU 

AA|  1      A  MD  ADA      /  A  /  If  \      A  /  If  .  7  \     A  /  If  .  9  \      A  /  If  9  \     A  /  If  9  .  1  \     A  /  If  9  i  9  \     VI     VI  \ 

LALL  LMPAKA    (A (K)  ,A (K+l )  ,A (K+Z ) , A (KZ )  ,A (KZ+1 )  ,A (KZ+2 )  , Al  ,  YI ) 

AMCl c  7  A 
b  Mb 15/0 

TC      /TCABIAft      *i\     7  A  A     /Oft     /  AA 

lr    (ItQUAL-Z)  700,690,690 

P  MC 1  con 
bMb 1580 

/.  10)  A 

690 

pii  i     A  UD  ADA     1  k  IV    7  \     A  /  1/  \     A  / 1/  ,  7  \     A  /  If  9    1  1     A  /  If  9  \     A  /  V  9  ■  T  A    Y7  V9\ 

LALL  LMrAKA    (A (K-l )  , A (K)  , A (K+I )  , A (K2-1 )  ,A (KZ )  , A  (KZ  +  1 )  ,AZ  ,  YZ ) 

AMCl EQn 

VI      A     ct  /  VI  .V*5\ 

X 1=0 .5    (Xl+XZ ) 

C  MC  1  A  A  A 
bMb 1600 

V  1      A             /  VI  .V*7\ 

Y 1=0 . 5    ( Yl+YZ ) 

A  MC  7  A  7  A 
bMb 16 10 

T  Art 

7  00 

T  C       /T0IIT>\      "flirt      T  1  A 

IF   (IUP)  710,710,720 

A  MC  7  A  9  A 
bMb!620 

710 

ir  h  o  n  A 

A  MC  7  A  1  A 

bMbl630 

K1=K1+1 

AMC  7  A  A  A 

bMbi640 

11     1  1  .  1 

L1=L1+1 

A  MC  7  A  C  n 
b  Mb 1650 

D/*  /  M  1  \  VI 

KL (Kl )=X1 

A  MC  7  A  A  A 

b  Mb  1 6  6  0 

RC (LI )=Y1 

A  MC  1  A  7  A 

bMbl670 

GO  TO  730 

A  MC  7  A  O  A 

brabl680 

720 

T  1      T  1  1 

I 1=1 1+1 

A  MC  7  A  O  A 

bMb 1690 

i  7       D  7   .  7 
J 1=J 1+1 

P  MC.  7  7  A  A 
b  Wl  J  1/UU 

nA / t 1 1 

Kb ( 11 )=X1 

A  MC 1 71 n 
b  Mj 1  /  i  U 

RC ( Jl )=Y1 

A  MC  7  7  9  A 

bMbl 7 20 

730 

AAUT  t  ft  I  II  IT 

COM  riKlUE 

A  MC  1  7  1  A 

bMbl730 

jA  ^\           jA       a  ■  -<v 

(SO  It)  350 

A  MC  7  7  A  A 

bmbl740 

EWD 

CMS1750 
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SUBROUTINE  COALES  COA  10 

C         VERSION    5.00         COALES         5/15/70  COA  20 

C           ACOALESCE  AND  AAVERAGE  COMMANDS  COA  30 

C           WRITTEN  BY  R.  MCCLENON ,  NSRDS-NBS ,  NOV.  1969  COA  40 

C           LI  =  ACOALESCE           L2  =  AAVERAGE  COA  50 

C         COMMAND  FORM  IS  —  COA  60 

C  ACOALESCE  MATRIX  STARTING  IN  R++  C++  COA  70 
C           ACOALESCE  ON  FIRST  COL  OF  ARRAY  IN  , ,  ++  R=,,  C=((  START  STORING  COA  80 

C  IN  ++  COA  90 
C           AAVERAGE  ON  FIRST  COL  OF  ARRAY  IN  , ,  ++  R=,,  C=, ,  START  STORING    COA  100 

C           IN  ,,  ++  COA  110 

C  OR  COA  120 
C           ACOALESCE  ON  **  IN  FIRST  COL  OF  , ,  ++  R=((  C= , ,  START  STORING        COA  130 

C           IN  , ,  ++  COA  140 

C           AAVERAGE  ON  **  IN  FIRST  COL  OF  , ,  ++  R=, ,  C=,,  START  STORING  COA  150 

C           IN  , ,  ++  COA  160 

COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG  COA  170 
COMMON  /BLOCKD /  IARGS (100 ), KIND (100 ) ,ARGTAB ( 100 ) ,NRMAX , NROW, NCOL ,NCOA  180 

1ARGS ,VWXYZ (8 ) ,NERROR  COA  190 

COMMON  /SCRAT/  NS  ,NS2  ,A  (13500)  COA  200 

COMMON  /BLOCRC/  NRC,RC(12600)  COA  210 

DIMENSION  ARGS(IOO)  COA  220 

EQUIVALENCE  (ARGS (1) ,RC (12501) )  COA  230 

L2=L2-8  COA  240 

IF  (NARGS-6)  410,10,20  COA  250 

10        KL=1  COA  260 

1=6  COA  270 

CALL  CKIND  (I)  COA  280 

IF  (1-1)  60,420,420  COA  290 

20        KL=2  COA  300 

DO  30  J=2,7  COA  310 

IF  (KIND(J))  420,30,420  COA  320 

30        CONTINUE  COA  330 

IF  (NARGS-8 )  40,410,410  COA  340 

40        IF  (KIND(l) )  420,420,50  COA  350 

50        Y=ARGS(1)  COA  360 

60        KL5=KL+5  COA  370 

DO  70  J=KL,KL5  COA  380 

IF  (IARGS(J))  430,430,70  COA  390 

70        CONTINUE  COA  400 

LR0W=IARGS(KL+2)  COA  410 

LC0L=IARGS(KL+3)  COA  420 

KROW=I ARGS (KL )  COA  430 

KC0L=IARGS(KL+1)  COA  440 

IF  (KROW+LROW-NROW-1)  80,80,440  COA  450 

80        IF  (KCOL+LCOL-NCOL-1)  90,90,440  COA  460 

90        MR0W=IARGS(KL+4)  COA  470 

MC0L=IARGS(KL+5)  COA  480 

IF  (MROW+LROW-NROW-1)  100,100,440  COA  490 

100      IF  (MCOL+LCOL-NCOL-1)  110,110,440  COA  500 

110      IF  (NERROR)  400,120,400  COA  510 

120      KRR=KR0W+LR0W-1  COA  520 

KCC=KC0L+LC0L-1  COA  530 

MRR=MR0W+LR0W-1  COA  540 

MCC=MC0L+LC0L-1  COA  550 

N=0  COA  560 

IF  (KL-1)  230,230,130  COA  570 

130      DO  140  J=2,LC0L  COA  580 

140      A(J)=0.0  COA  590 
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A(1)=Y 

DO  170  J=1,LR0W 

I=KR0W+J-1 

II=NR0W*(KC0L-1)+I 

IF   (RC(II)-Y)  170,150,170 
150      DO  160  JJ=2,LC0L 

I=II+(JJ-1)*NR0W 
160  A(JJ)=A(JJ)+RC(I) 

N=N+1 
170  CONTINUE 

IF   (N)  460,460,180 
180  M=l 

GO  TO  (190,200)  ,  L2 
190  DIV=1.0 

GO  TO  210 
200  DIV=N 

210      DO  220  JJ=2,LC0L 
220      A(JJ)=A(JJ) /DIV 

GO  TO  380 
230  MAT=LCOL*LROW 

IF  (MAT-NS+LROW)  240,240,450 
240  M1=MAT+1 

M2=MAT+LR0W 

DO  250  J=M1,M2 
250  A(J)=0. 

M=0 

DO  370  J=1,LR0W 
M1=MAT+J 

IF   (A(M1))  370,260,370 
260  K1=LC0L*M+1 

K2=LC0L* (M+l) 

DO  270  K=K1,K2 
270  A(K)=0.0 

N=0 

L=NR0W*(KC0L-1)+J 

Y=RC(L) 

A(K1)=Y 

DO  300  JJ=J,LROW 

I I=NROW* (KCOL-1 ) +KROW+J J-l 

IF   (RC(II)-Y)  300,280,300 
280  K3=K1+1 

M1=MAT+JJ 

A(M1)=1.0 

DO  290  K=K3,K2 

I=II+(K-K1)*NR0W 
290      A(K)=A(K)+RC(I ) 

N=N+1 
300  CONTINUE 

IF   (N)  370,370,310 
310  W=M+1 

320      GO  TO  (330,340)  ,  L2 
330  DIV=1.0 

GO  TO  350 
340  DIV=N 
350      DO  360  K=K3,K2 
360      A(K)=A(K) /DIV 
370  CONTINUE 
380      DO  390  J=1,M 

DO  390  JJ=1,LC0L 


COA  600 
COA  610 
COA  620 
COA  630 
COA  640 
COA  650 
COA  660 
COA  670 
COA  680 
COA  690 
COA  700 
COA  710 
COA  720 
COA  730 
COA  740 
COA  750 
COA  760 
COA  770 
COA  780 
COA  790 
COA  800 
COA  810 
COA  820 
COA  830 
COA  840 
COA  850 
COA  860 
COA  870 
COA  880 
COA  890 
COA  900 
COA  910 
COA  920 
COA  930 
COA  940 
COA  950 
COA  960 
COA  970 
COA  980 
COA  990 
C0A1000 
C0A1010 
C0A1020 
C0A1030 
C0A1040 
C0A1050 
C0A1060 
C0A1070 
C0A1080 
C0A1090 
C0A1100 
COA1110 
COA1120 
C0A1130 
C0A1140 
C0A1150 
C0A1160 
C0A1170 
C0A1180 
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I=LC0L* ( J- 

1)+JJ 

I I=NR0W* (MC0L-2+JJ )+J+MR0W-l 

LUA1190 

RC(II)=A(I) 

C0A1200 

390 

CONTINUE 

C0A1210 

400 

RETURN 

C0A1220 

410 

CALL  ERROR 

(10) 

C0A1230 

GO  TO  400 

C0A1240 

A  O  A 

420 

CALL  ERROR 

(20) 

C0A1250 

GO  TO  400 

C0A1260 

A1  t\ 

CALL  ERROR 

(11) 

C0A1270 

GO  TO  400 

COA1280 

A  A  f\ 

CALL  ERROR 

(17) 

C0A1290 

GO  TO  400 

C0A1300 

A  C  ft 

CALL  ERROR 

(23) 

C0A1310 

GO  TO  400 

C0A1320 

CALL  ERROR 

(203) 

C0A1330 

M=l 

C0A1340 

GO  TO  380 

C0A1350 

END 

C0A1360 
C0A1370 
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FUNCTION  COMELL  (Z,I)  COM  10 

C         VERSION    5.00         COMELL         5/15/70  COM  20 

C  COMPLETE  ELLIPTIC  INTEGRALS  -  FIRST  AND  SECOND  KIND  COM  30 

DOUBLE  PRECISION  Z,X,A,B,C,D,E,P(Q  COM  40 

DOUBLE  PRECISION  FDLOG , FDSQRT , COMELL  COM  50 

X=Z  COM  60 

IF  (DABS(Z)  .LT.l.DO)  GO  TO  10  COM  70 

IF(DABS(Z) .EQ.l.DO.AND.I .EQ.2)     GO  TO  10  COM  80 

CALL  ERROR  (109)  COM  83 

Z=O.ODO  COM  85 

RETURN  COM  90 

10        A=X  COM  100 

B=FDSQRT(1 .DO-A)  COM  110 

IF  (X.GT. .996D0)  GO  TO  50  COM  120 

B=(l .DO-B) / (1 .DO+B)  COM  130 

A=B**2  COM  140 

B=1.D0+B  COM  150 

C=1.D0  COM  160 

D=C  COM  170 

E=2 . DO  COM  180 

IF  (I.EQ.l)  GO  TO  20  COM  190 

B=1.D0/B  COM  200 

D=-1.D0  COM  210 

20        P=A  COM  220 

DO  30  N=l,90  COM  230 

C=C+P*(D/E)**2  COM  240 

P=P*A*(D/E)**2  COM  250 

IF  (P.LT..1D-9)  GO  TO  40  COM  260 

D=D+2.D0  COM  270 

30        E=E+2.D0  COM  280 

40        A=B*C*1 .570796326D0  COM  290 

GO  TO  70  COM  300 

50        A=FDL0G(4.0D0/B)  COM  310 

Q=B**2  COM  320 

IF  (I .GT.l)  GO  TO  60  COM  330 

B=.25D0* (A-l.DO)  COM  340 

C=.140625D0*(A-1.666666666D0)  COM  350 

D=9.765625D-2*(A-1.233333333D0)  COM  360 

E=1255.D0*(A-1 .27904761904D0) / 16384. DO  COM  370 

A=A+Q* (B+Q* (C+Q* (D+Q*E) ) )  COM  380 

GO  TO  70  COM  390 

60        B=.5D0* (A-.5D0)  COM  400 

C=.1875D0*(A-1.083333333D0)  COM  410 

D=.1171875D0*(A-1.2D0)  COM  420 

E=175.D0*(A-1.251190476D0)/2048.D0  COM  430 

A=1.+Q*(B+Q*(C+Q*(D+Q*E)))  COM  440 

70        COMELL=A  COM  450 

RETURN  COM  460 

C  COM  470 

EM)  COM  490 
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990 
£  7  U 

p 

cox 

300 

p 

NARGS  =  6  FOR  ADD , SUB , MULT , DIV 
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NARGS  =  4  FOR  CRECTANGULAR  AND  CP0LAR 
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ERROR  CHECKING 
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IF  (NARGS  NE  6  AND  L2  LT  5)  CALL  ERROR  (10) 
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CALL  ERROR  (11) 
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IF  (NERROR.NE.O)  RETURN 
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IF  (L2.GT.4)  GO  TO  140 
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CSUBTRACT 

COX  600 
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X=D(3)-D(1) 

COX  610 

Y=D(4)-D(2) 

COX  620 

GO  TO  120 

COX  630 
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CMULTIPLY 

COX  640 
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X=D(1)*D(3)-D(2)*D(4) 

COX  650 

Y=D(1)*D(4)+D(3)*D(2) 

COX  660 

GO  TO  120 

COX  670 

C 

CDIVIDE 

COX  680 

C 

ZERO  RETURNED  IF  DIVISION  BY  ZERO,  DIAGNOSTIC  GIVEN.  ERR0R(104). 

COX  690 
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D(5)=D(3)**2+D(4)**2 

COX  700 
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GO  TO  120 
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I2=I2+KK(2) 

COX  810 

I3=I3+KK(3) 

COX  820 

I4=I4+KK(4) 

COX  830 
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I5=I5+KK(5) 

COX  840 

RETURN 
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CRECTANGULAR  AND  CPOLAR 

COX  860 
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MM=L2-4 

COX  870 

DO  260  1=14, JJ 

COX  880 

D(1)=RC(I1) 

COX  890 

D (2 )=RC (12) 

COX  900 

GO  TO  (150,190) ,  MM 

COX  910 
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CRECTANGULAR  -  R,THETA  TO  X,Y 

COX  920 

150 

IF  (RC(I1))  180,160,180 

COX  930 
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COX  940 
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Y=O.ODO 

COX  950 

GO  TO  250 

COX  960 
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X=D(1)*FDC0S(D(2) ) 

COX  970 

Y=D(1)*FDSIN(D(2)) 

COX  980 

GO  TO  250 
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CPOLAR        X,Y  TO  R,THETA 
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IF  (RC ( 12 ) )  220,200,220 
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IF  (RC(I1))  210,160,210 
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Y=0,  X  NE  0 

C0X1030 
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X=DABS(D(1)) 

C0X1040 

GO  TO  170 

C0X1050 
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IF   (RC(I1)  )  240,230,240 
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X=0,  Y  NE  0 
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X=DABS (D (2) ) 
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GO  TO  250 
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X=FDSQRT(D(1)**2+D(2)**2) 
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Y=DATAN2 (D (2 )  ,D  (1) ) 
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RC(I3)=FDPC0N(X) 
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RC(I)=FDPCON(Y) 

C0X1150 

I1=I1+KK(1) 

C0X1160 

I2=I2+KK (2 ) 

C0X1170 
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I3=I3+KK(3) 

C0X1180 

RETURN 

C0X1190 

END 

C0X1200 
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SUBROUTINE  CORREL 
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10 

c 

VERSION    5.00         CORREL  5/15/70 

COR 

20 

COMMON  /BLOCKD /  IARGS(IOO) ,KIND(100) ,ARGTAB (100) , NRMAX ,NROW,NCOL  ,NCOR 

30 

1ARGS,VWXYZ(8) ,NERROR 

COR 

40 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG 

COR 

50 

COMMON  /BLOCRC/  NRC , RC ( 12600 ) 

COR 

60 

DIMENSION  ARGS(IOO) 

COR 

70 

EQUIVALENCE  (ARGS (1 ) ,RC (12501 )  ) 

COR 

80 

COMMON  /HEADER /  NOCARD (80) , ITLE (60 , 6) , LNCNT , I  PR  I NT ,NPAGE , I  PUNCH 

COR 

90 

COMMON  /SCRAT/  NS  ,NS2 ,A  (13500) 

COR 

100 

DIMENSION  ERR (3 ) ,  AVG(IOO),  SD(IOO),  T(100) 

COR 

110 

EQUIVALENCE  (A ( 13301 ) , AVG ( 1 ) ) ,   (A ( 13401 ) , SD  ( 1 ) , T ( 1 ) ) 
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120 

L2=L2-10 
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IF  (L2.EQ.1.0R.NARGS.NE.IARGS(1)  +1)  GO  TO  10 

COR 

124 

CALL  ERROR  (233) 

COR 

126 

RETURN 

COR 

128 

10 

MVAR=99 

COR 

130 

IF  (NARGS.LT.3)  CALL  ERROR  (10) 

COR 

140 

NVAR=IARGS(1) 

COR 

150 

IF  (NVAR.LT.2.0R.NVAR.GT.MVAR)  CALL  ERROR  (3) 

COR 

160 

KEEP=(NARGS-NVAR+l)/2 

COR 
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IF  (KEEP . LT . 1 .OR .KEEP .GT . 3 .OR .MOD (NARGS-NVAR  2 ) .EQ . 0 )  CALL 

ERROR 
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180 

110) 

COR 

190 

GO  TO  (40,30,20) ,  KEEP 
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200 

20 

K2=IARGS(NVAR+4) 
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210 

IF  (K2.LT.1.0R.K2.GT.NR0W)  CALL  ERROR  (16) 
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220 

IARGS(NVAR+4)=1 
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230 

30 

Kl=IARGS(NVAR+2) 
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240 

IF  (K1.LT.1.0R.K1.GT.NR0W)  CALL  ERROR  (16) 

COR 

250 

IARGS(NVAR+2)=1 

COR 

260 

40 

CALL  CHKCOL  (J) 

COR 

270 

IF  (J.EQ.O)  GO  TO  50 

COR 

280 

CALL  ERROR  (11) 

COR 

290 

RETURN 

COR 

300 

50 

GO  TO  (80,70,60) ,  KEEP 

COR 

310 

60 

IARGS (NVAR+4)=IARGS (NVAR+5 )+K2-l 

COR 

320 

70 

IARGS (NVAR+2 )=IARGS (NVAR+3 )+Kl-l 

COR 

330 

80 

LOTTE=NVAR*NVAR 

COR 

340 

KURT=2*L0TTE 

COR 

350 

C 

LOT  IS  SPACE  IN  ARRAY  A  RESERVED  FOR  RANKED  DATA 

COR 

360 

LOT=MAXO (NRMAX* (NVAR+1) ,3*L0TTE+8*NVAR+8 ,4*L0TTE) 

COR 

370 

IF  (NRMAX. LT. 3)  CALL  ERROR  (9) 

COR 

380 

IF  (NRMAX*NVAR.GT.NRC)  CALL  ERROR  (15) 

COR 
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IF  (MAXO (LOT+LOTTE+100 ,NRMAX*4+3*L0TTE) .GT .NS)  CALL  ERROR 

(23) 

COR 
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IF  (NERROR.NE.O)  RETURN 
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410 

NVA=NVAR-1 
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420 

IF  (L2.EQ.2)  GO  TO  130 
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C 

RANKS  OF  OBSERVATIONS 
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440 

IND  =  NVAR  *NRMAX+1 
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450 

DO  90  I=1,NVAR 
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K1=(I-1)*NRMAX+1 
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K2=IARGS(I+1) 
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90 

CALL  RANKX  (NRMAX ,RC (K2 ) , A ( IND) , A (Kl ) ,T ( I ) ) 
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C 

SPEARMAN  RANK  CORRELATION  COEFFICIENT 
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500 

F=( (NRMAX-1 ) *NRMAX* (NRMAX+1) ) /6 
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510 

I1=L0T+L0TTE 
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520 

A(I1)=1. 
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530 

DO  120  J=1,NVA 

COR 

540 

IND=(J-1)*NVAR+L0T 
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550 
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IF  (ABS (A ( 1 1 ) ) .GT.l.)  A (11) 

=AINT(A(I1) ) 

C0R1150 

200 

A(I2)=A(I1) 

C0R1160 

IF  (NVAR.LE.2)  GO  TO  210 

C0R1170 

C 

PARTIAL  CORRELATION  COEFFICIENT 

C0R1180 

CALL  INVCOR  (A (1 ) ,NVAR , NVAR , A (LOTTE+1 ) , NVAR+2 , A (1 ) , 1 ,ERR , IND ) 

C0R1190 

IF  (IND.EQ.O)  GO  TO  220 

C0R1200 

WRITE  (IPRINT,480) 

C0R1210 

210 

KEEP=MIN0(KEEP,2) 

C0R1220 

A (LOTTE+1 )=0. 

C0R1230 

IF  (L2.EQ.1)  GO  TO  300 

C0R1240 

GO  TO  420 

C0R1250 
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DO  230  J=2,NVAR 

C0R1260 

K1=2*(J-1) 

C0R1270 

K2=L0TTE+(J-1)*NVAR 

C0R1280 

DO  230  I=1,NVAR 

C0R1290 

I1=K2+I 

COR1300 

I2=I1+K1 
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A(I1)=A(I2) 
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DO  240  J=1,NVA 
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IND=L0TTE+(J-1)*NVAR 
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DO  240  I=IJ,NVAR 
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C0R1380 
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A(I1)=1. 

C0R1460 

IF  (L2.EQ.2)  GO  TO  420 

C0R1470 

IF  (NRMAX.LE.NVAR)  GO  TO  300 

C0R1480 

C 

SIGNIFICANCE  LEVEL  OF  PARTIAL  CORRELATION  COEFFICIENT 

C0R1490 

Z=FLOAT (NRMAX-NVAR ) 

C0R1500 

DO  290  J=1,NVAR 

C0R1510 

IJ=(J-1)*NVAR+L0TTE 

C0R1520 

IND=IJ+KURT 

C0R1530 

DO  290  I=J,NVAR 

C0R1540 

Il=IND+I 

COR1550 

I2=(I-1)*NVAR+J+3*L0TTE 

C0R1560 

K1=IJ+I 

C0R1570 

IF  (A(K1))  270,260,270 

C0R1580 

260 

A(I1)=1 . 

C0R1590 

GO  TO  290 

C0R1600 

270 

IF  (ABS(A(K1)) .LT.l.)  GO  TO 

280 

C0R1610 

A(I1)=0. 

COR1620 

GO  TO  290 

C0R1630 

280 

F=A(K1)*A(K1) 

C0R1640 

F=Z*F/(1.-F) 

C0R1650 

CALL  PROB  (1. ,Z,F,A(I1)) 

COR1660 

290 

A(I2)=A(I1) 

C0R1670 

300 

Z=FLOAT (NRMAX-2 ) 

C0R1680 

DO  340  J=1,NVAR 

COR1690 

IJ=(J-1)*NVAR 

C0R1700 

IND=IJ+KURT 

C0R1710 

DO  340  I=J,NVAR 

C0R1720 

I1=IND+I 

C0R1730 
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PAD 1 Q  o n 

LUKlVoO 
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NLA=NLA+2 

PAD 1  A A A 

LUK1990 

TC      /AIDAIAV     1  C     AI\/AD\     PA    TA  7CA 

lr    (NKMAX . Lt . NVAK )   bU    IU  350 

PAD 1 A  A  A 

LUK2000 
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LALL  Mlbl    (NVAK , A  (3   LU 1  1 1+1 )  , 1 , NLA , 4 ) 

P AD 1 A 1  A 

LUK2010 
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PAII      LA  T  CT      /AIWAD     A/I  AT  .  1  \     1     Al  1  A     C  \ 

LALL  Mlbl    (NVAK , A (LU 1 +1 ) , 1 , NLA , 5 ) 

P  AD  1  A A 

LUK2020 

TC      /AIDAIAV     PT     7\     PA    TA     1  £.  f\ 

lr    (NKMAX. bl .3)   bU    IU  360 

P AD 1 A 1  A 

LUK2030 

IAIDTTC      /T  DDT  AIT     CAA\  AIDAIAV 
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P  AD  1  A  Jl  A 

LUK2040 
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bU    IU  420 

PAD 1 A  C  A 

LUK2050 

1  L  A 

360 

"7    CI  AAT/AIDAJAV  7\ 

£=rLUAI (NKMAX-3) 

P  A  D  O  A  L  A 

LUKZ060 

TAin     7  *  1  ATTC  .AIDAIAV  .  1 

1NU=3  LUI 1 t+NKMAX+1 

P  AD 1 A  T  A 

LUKZ070 

da  Ann    i    i    aii/ a d 
UU  400  J=1,NVAK 

pad  0  non 

Ti      T  A  DP  C  /  1  .  1  \ 

1 1=1 AKbb ( J+l ) 

P AD 1 A  A  A 

LUK2090 

TI      /I     1  \  *  All/ A  D 

1 J= ( J-l )  NVAK 

P  AD 1 1  A  A 

LUK2100 

l\A     i  An     T     i     All/ AD 

UU  400  1=1,NVAK 

P  AD  O 1  1  A 

LUKZ110 

TC      /T     AIC      l\     A  A    TA  17rt 

lr    (l.Nt.J)   bU   IU  3/0 

PAD*)  1  OA 

LUK11Z0 

TI     l/IIDT.T   1.  1 

1  2=I\UK  1  +1J+J 

PAD  O 1  7  A 

LUK1130 

A   /  T  A  \  1! 

A(I2)=1. 

P  AD  O  1  /I  A 

LUK2140 

A  A     T  A      A  A  A 

GO  10  400 

PADO  T  C  A 

LUK2150 

1  "T  A 

370 

T  A      T  A  D  A  C  /  T      1  \  1 

I2=IARGb ( I +1 ) — 1 

prtnfti  /  a 

LUK2 160 

nA    i  o  a    i/    i  hiDiJAV 

DO  380  K=l, NKMAX 

P AD 1 1  7  A 

LUK2170 

1/1      1/  ,  TO 

K1=K+1 2 

P AD  O 1  OA 

LUK2180 

1/  A    1/     1  *  n  ATTC 

K2=K+3*L0 1 1 t 

PADO 1  A A 

LUK2190 

*>  A  A 

380 

A    /  1/  A  \  DjA/I/IV 

A (K2 )=RC (Kl ) 

P  AD  1  *>  A  A 

LUK2200 

TA     l/MDT.T  I.T 

LUKZZ10 

AAII       D  1  AD  Al/      /  D  A  /  T  l  v      A  /            ATTC  .  1  \      AID  MA  V     A  /  T  Al  A  \      C  \ 

CALL  BJORCK   (RC (11) , A (3 'LOT T t+1 ) ( NKMAX ,  A ( 1ND ) , r ) 

PAD 1 O  O  A 

LUK2220 

TC      /C     AT     A      \      AA     TA     O  A  A 

IF   (F.GT.0.)  GO  TO  390 

p AD o 7  in 
LUKZZ^O 

A  /  T  O  \  1 

A(I2)=1 . 

A  A     T  A      A  A  A 

GO  TO  400 

PADO 1 C A 

LUKZZ5U 

1  A  A 

390 

A  A  1   1       AD AD      /  1         7     C     A  /  T  A  \  \ 

CALL  PR0B   (1 .  ,Z , r , A ( 12 ) ) 

PAD  7  7  £.  A 

LUKZ260 

A  A  A 

400 

A  A  AIT  T  All  IC 

CONTINUE 

PAD  7  O  7  A 

LUKZZ70 

AAII       lit  CT      /All/ AD     A/l/llDT     1\      A     All   A  L\ 

CALL  MIST   (NVAR , A (KURT+1 ) , 0 ,NLA , 6 ) 

PAD  7  7  O  A 

LUK2Z80 

L 

P  AAIC  T  nCAIPC    1  TIITTC    cad    C  T  AID  1  C    PADDCI  ATTAAl  PACCCTPTCaIT 

LUNrlUtNLt  L 1  Ml  lb  r UK  blMrLt  LUKKtLA 1 1 UN  LUthrlLltNl 

A AD  7  7  A  A 

LUK££7U 

C     CCrtDT  /  CI  AAT/AID  AAA  V     7  \  \ 

F=rbQKI (FLOAT (NRMAX-3) ) 

PAD  7 I AA 

L-UKZ  j00 

Ml  1—9  l»7Qfl9Q1/P 

n l L—L  .  o  i  jo t.7 j  /  r 

HL2=1.9599640/F 

COR2320 

60 


410 

420 
C 

430 


440 
450 


460 
470 

C 

480 
490 
500 


SCC  CONFIDENCE  LIMITS  (99  PER  CENT  LEVEL) 


A(3*L0TTE)-99. 
A(5*L0TTE)=95. 
DO  410  J=1,NVA 
IND=(J-1)*NVAR 
K1=IND+J+KURT 
K2=K1+KURT 
A(K1)=99. 
A(K2)=95. 
IJ=J+1 

DO  410  I=IJ,NVAR 
INDEX  OF  SCC 
Il=IND+I 

INDICES  OF  UPPER, LOWER 
K1=(I-1)*NVAR+J+KURT 
K2=K1+KURT 

Z=.5*FL0G((1.+A(I1))/(1.-A(I1))) 
A (Kl )=AMIN1 (FTANH (Z+HL1 ) , 1 . ) 
A (K2 )=AMAX1 (FTANH (Z-HL1 ) ,-1.) 
INDICES  OF  UPPER,  LOWER  SCC  CONFIDENCE 
K1=I1+KURT 
K2=K1+KURT 

A (K1)=AMIN1 (FTANH (Z+HL2 ) , 1 . ) 
A (K2 )=AMAX1 (FTANH (Z-HL2 ) ,-1 . ) 
CALL  MIST  (NVAR ,A (KURT+1 ) ,0 ,NLA ,7 ) 
GO  TO  (470,450,430) ,  KEEP 

STORE  SIMPLE  AND  PARTIAL  CORRELATION  COEFFICIENTS 

I 1=MIN0 (NVAR, NCOL-( IARGS (NVAR+5)-l) /NROW) 

I 2=MIN0 (NVAR ,NROW-( IARGS (NVAR+4 ) -IARGS (NVAR+5) ) ) 

IF  (II. LT.NVAR.0R.I2.LT. NVAR)  CALL  ERROR  (213) 

DO  440  J=1,I1 

DO  440  1=1,12 

K1=(J-1)*NVAR+I+L0TTE 

K2=IARGS(NVAR+4)-l+(J-l)*NR0W+I 

RC(K2)=A(K1) 

I 1=MIN0 (NVAR , NCOL- (IARGS (NVAR+3 ) -1 ) /NROW) 

I 2=MI NO (NVAR , NROW- (IARGS (NVAR+2 ) -IARGS (NVAR+3 ) ) ) 

IF  (II. LT.NVAR.0R.I2.LT. NVAR)  CALL  ERROR  (213) 

DO  460  J=l ,11 

DO  460  1=1,12 

K1=(J-1)*NVAR+I 

K2=IARGS (NVAR+2 )-l+( J-l ) *NROW+I 

RC(K2)=A(K1) 

RETURN 


LIMITS  (95  PER  CENT  LEVEL) 


IN  WORKSHEET 


(1H  ,32X,54HMATRIX  IS  SINGULAR.     NO  PARTIAL  CORRELATIONS 

) 


FORMAT 
IMPUTED 

FORMAT  (/30X,24HC0RRELATI0N  ANALYSIS  F0R,I3,15H  VARIABLES 
113H  OBSERVATIONS) 

FORMAT  (1H  ,18X,83HN0NLINEARITY  TEST  AND  APPROXIMATION  OF 
ICE  INTERVALS  NOT  DEFINED  FOR  NRMAX  =,12) 

END 


C0R2330 
C0R2340 
C0R2350 
C0R2360 
C0R2370 
C0R2380 
C0R2390 
C0R2400 
C0R2410 
C0R2420 
C0R2430 
C0R2440 
C0R2450 
C0R2460 
C0R2470 
C0R2480 
COR2490 
C0R2500 
C0R2510 
C0R2520 
C0R2530 
C0R2540 
C0R2550 
C0R2560 
C0R2570 
C0R2580 
C0R2590 
C0R2600 
C0R2610 
C0R2620 
C0R2630 
C0R2640 
C0R2650 
C0R2660 
C0R2670 
C0R2680 
C0R2690 
COR2700 
C0R2710 
C0R2720 
C0R2730 
C0R2740 
C0R2750 
C0R2760 
C0C0R2770 
COR2780 
WITH,I5,COR2790 
COR2800 
C0NFIDENC0R2810 
C0R2820 
C0R2830 
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CONTINUE 
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INTERCHANGE  ROW  Jl  WITH  ROW  L .  Jl  IS  THE  ROW  WITH  THE  LARGEST  ELEMCSP 

1  Oft 
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TEST  TO  SEE  IF  INTERCHANGING  IS  NECESSARY. 

CSP 
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IF  (Jl-L)  80,100,80 

CSP 

A  ft  ft 

400 

80 

DO  90  J=L,N2 

CSP 

A  1  ft 
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JC0L=NN*J-NN 

CSP 
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KJIJ=JC0L+J1 

CSP 
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CSP 
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KLJ=JC0L+L 
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CSP 

A  Cft 

4  to  0 
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90 

CONTINUE 
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IF  THE  LARGEST  ABSOLUTE  ELEMENT  IN  A  COLUMN  IS  MACHINE  ZERO  WE 
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c 
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CSP 
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DO  160  I=L1,L2 
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SUBROUTINE  DEFINE 

DEF 

10 

c 

VERSION    5.00         DEFINE  5/15/70 

DEF 

20 

COMMON  /BLOCRC/  NRC ,RC (12600) 

DEF 

30 

COMMON  /BLOCKD/  IARGS(IOO) ,KIND(100) ,ARGTAB (100) , NRMAX ,NR0W,NCQL ,NDEF 

40 

1ARGS,VWXYZ(8) ,NERR0R 

DEF 

50 

DIMENSION  ARGS(IOO) 

DEF 

60 

EQUIVALENCE  (ARGS (1) ,RC (12501) ) 

DEF 

70 

c 

DEF 

80 

c 

DEFINE  $$  INTO  COLUMN  ++ 

DEF 

85 

c 

DEFINE  $$  INTO  ROW  ++,  COL  ++. 

DEF 

90 

c 

DEFINE  ROW  ++,  COL  ++  INTO  ROW  ++,  COL 

+  +  . 

DEF 

100 

c 

DEFINE  ROW  ++,  COL  ++  INTO  COL  ++. 

DEF 

110 

c 

DEF 

120 

IF(NARGS.NE.2)  GO  TO  5 

DEF 

122 

J=l 

DEF 

124 

IF  (KIND  (1)  .EQ  .0)  CALL  ADRESS(IJ) 

DEF 

125 

CALL  ADRESS  (2,1) 

DEF 

126 

IF  (I )  120,130,2 

DEF 

127 

2 

IF  (J )  120,130,60 

DEF 

128 

5 

IF(NARGS.NE.3)  IF(NARGS-4)  115,40,115 

DEF 

129 

IF  (KIND(l) .EQ.O)  GO  TO  40 

DEF 

130 
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I=NARGS 

DEF 

140 

GO  TO  90 
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IF  (NERROR.EQ.O)  RC (L)=ARGS (1 ) 

DEF 
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RETURN 
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1=2 

DEF 

180 

GO  TO  90 

DEF 

190 

50 

ARGS(1)=RC(L) 

DEF 

200 

IF  (NARGS.EQ.4)  GO  TO  10 

DEF 

210 

CALL  ADRESS  (3,1) 

DEF 

220 

IF  (I)  120,130,60 

DEF 

230 

60 

IF  (NERROR.NE.O)  GO  TO  30 

DEF 

240 

IF  (NRMAX. EQ.O)  GO  TO  70 

DEF 

250 

IF (KIND (1) . EQ . 0 . AND . NARGS . EQ . 2 )  GO  TO 

140 

DEF 

255 

CALL  VECTOR  (ARGS(l) ,1) 

DEF 

260 

GO  TO  30 

DEF 

270 

70 

1=9 

DEF 

280 
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CALL  ERROR  (I) 

DEF 

290 

GO  TO  30 

DEF 

300 

c 

DEF 

310 

c 

CHECK  AND  CALCULATE  WORKSHEET  ENTRY  LOCATION  INTO  L 

DEF 

320 
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DEF 
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CALL  ADRESS  (I,L) 

DEF 

340 

IF  (L)  120,130,100 

DEF 
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IF  (KIND(I-l) .EQ.O. AND. IARGS(I-l) .GT.O 
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DEF 
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GO  TO  80 
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DEF 
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GO  TO  80 
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Utr 
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RC(I)=RC(J) 

DEF 
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1=1+1 
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150 

J=J+1 

DEF 
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RETURN 

DEF 
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END  66 
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DET 
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DET 
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DHR  10 

SUBROUTINE  DHRND  (X,N,XT)  DHR  20 

C         VERSION    5.00         DHRND         5/J5/70  OHR  30 

C         SUBROUTINE  TO  ROUND  X  TO  M  SO  AND  STORE    I J  XT  4Q 

C         WRITTEN  BY  DAVID  HOGBEN,  SEL,  NBS .     4/09/70.  DHR  5Q 

DOUBLE  PRECISION  Z  DHR  60 

IF  (X)  20,10,20  DHR  70 

10        XT=0.0  DHR  80 

RETURN  DHR  90 

20        IF  (N.LT.l)  N=l  DHR  100 

IF  (N.GT.8)  N=8  DHR  110 

Y=ABS(X)  DHR  120 

M=FL0G10(Y)  DHR  130 

IF  (Y.LT.1.0)  l*=M-l  DHR  140 

Z=Y  DHR  150 

Z=Z*10.D0**(8-M)  DHR  160 

IF  (Z.LT.1.0D+9)  GO  TO  30  DHR  170 

M=M+1  DHR  180 

Z=Z/10.0D0  DHR  190 

GO  TO  40  DHR  200 

30        IF  (Z.GE.1.0D+8)  GO  TO  40  DHR  210 

M=M-1  DHR  220 

Z=10.0D0*Z  DHR  230 

40        X1=Z  DHR  240 

LL1=X1  DHR  250 

X2=Z-DBLE(X1)  DHR  260 

LL2=X2  DHR  270 

LL=LLl+LL2+5  DHR  280 

LL1=LL/(10**(9-N))  DHR  290 

LL2=LL1*10**(9-N)  DHR  300 

LL2=LL-LL2  DHR  310 

IF  (N.EQ.8)  GO  TO  70  DHR  320 

IF(LL2/10-5*10**(7-N))  70,50,60  DHR  330 

50        LL2=M0D(LL1,2)  DHR  340 

IF  (LL2)  70,70,60  DHR  350 

60        LL1=LL1+1  DHR  360 

70       XT=FLOAT (LL1)  DHR  370 

IF  (M.EQ.N-1)  GO  TO  80  DHR  380 

C  DHR  390 

Z=XT  DHR  400 

Z=Z*10.0D0**(M-N+1)  DHR  410 

XT=FDPCON(Z)  DHR  420 

80       XT=SIGN(XT,X)  DHR  430 

RETURN  DHR  440 
END 
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SUBROUTINE  D I  MENS 

VERSION    5.00         D I  MENS  5/15/70 
COMMON  /BLOCRC/  NRC  ,RC  (12600) 

COMMON  /BLOCKD /  IARGS (100) ,KIND (100) .ARGTAB (100) 
1ARGS,VWXYZ(8) ,NERROR 
DIMENSION  ARGS(IOO) 
EQUIVALENCE  (ARGS (1 ), RC (12501 ) ) 
IF  (NARGS.EQ.2)  IF  (KIND(1)+KIND(2) )  25,27,25 
K=10 

CALL  ERROR  (K) 

RETURN 

K=20 

GO  TO  10 

IF  (IARGS (1) .GT.0.AND.IARGS(2) .GT . 0 .AND . IARGS ( 1 ) 
1G0  TO  30 
K=3 

GO  TO  10 

NR0W=IARGS(1) 

NC0L=IARGS(2) 

NRMAX=MINO (NROW,NRMAX) 

GO  TO  20 

END 


DIM  10 

DIM  20 

DIM  30 

,NRMAX ,NROW,NCOL ,NDIM  40 

DIM  50 

DIM  60 

DIM  70 

DIM  75 

DIM  80 

DIM  90 

DIM  100 

DIM  110 

DIM  120 

*IARGS(2) . LE .NRC)  DIM  130 

DIM  140 

DIM  150 

DIM  160 

DIM  170 

DIM  180 

DIM  190 

DIM  200 

DIM  210 
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SUBROUTINE  DUMMYA  DMA  10 

VERSION    5.00         DUMMYA         5/15/70  DMA  20 

PRINT  10  DMA  30 

FORMAT (55H  *  OMNI TAB  COMMAND  DUMMYA  IS  NOT  AVAILABLE  AT  THIS  TIME) DMA  40 

RETURN  DMA  50 

END  DMA  60 


SUBROUTINE  DUMMYB                                                                                DMB  10 

VERSION    5.00         DUMMYB         5/15/70                                                    DMB  20 

PRINT  10                                                                                                   DMB  30 

FORMAT (55H  *  OMNITAB  COMMAND  DUMMYB  IS  NOT  AVAILABLE  AT  THIS  TIME) DMB  40 

RETURN                                                                                                      DMB  50 

END                                                                                                           DMB  60 


SUBROUTINE  DUMMYC                                                                                    DMC  10 

VERSION    5.00         DUMMYC         5/15/70                                                    DMC  20 

PRINT  10                                                                                                   DMC  30 

FORMAT (55H  *  OMNITAB  COMMAND  DUMMYC  IS  NOT  AVAILABLE  AT  THIS  TIME) DMC  40 

RETURN                                                                                                  DMC  50 

END                                                                                                           DMC  60 


SUBROUTINE  DUMMYD                                                                                    DMD  10 

VERSION    5.00         DUMMYD         5/15/70                                                    DMD  20 

PRINT  10                                                                                                   DMD  30 

FORMAT (55H  *  OMNITAB  COMMAND  DUMMYD  IS  NOT  AVAILABLE  AT  THIS  TIME) DMD  40 

RETURN                                                                                                      DMD  50 

END                                                                                                           DMD  60 


SUBROUTINE  DUMMYE                                                                                DME  10 

VERSION    5.00         DUMMYE         5/15/70                                                    DME  20 

PRINT  10                                                                                                   DME  30 

FORMAT (55H  *  OMNITAB  COMMAND  DUMMYE  IS  NOT  AVAILABLE  AT  THIS  TIME) DME  40 

RETURN                                                                                                  DME  50 

END                                                                                                           DME  60 


SUBROUTINE  DUMMYF                                                                                   DMF  10 

VERSION    5.00         DUMMYF         5/15/70                                                    DMF  20 

PRINT  10                                                                                                   DMF  30 

FORMAT (55H  *  OMNITAB  COMMAND  DUMMYF  IS  NOT  AVAILABLE  AT  THIS  TIME) DMF  40 

RETURN                                                                                                  DMF  50 

END                                                                                                           DMF  60 
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SUBROUTINE  ERASE  ERA  10 

C         VERSION    5.00         ERASE           5/15/70  ERA  20 

C  ERA  30 

C         ERASE  COL  (C) ,   (C) ,   (C) ,  ETC.  ERA  40 

C         IF  NO  COLS  SPECIFIED  ALL  OF  WORKSHEET  IS  ERASED  ERA  45 

C  ERA  50 

COMMON  /BLOCRC/  NRC , RC ( 12600 )  ERA  60 
COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) ,NRMAX ,NROW,NCOL ,NERA  70 

1ARGS ,VWXYZ (8) ,NERROR  ERA  80 

DIMENSION  ARGS(IOO)  ERA  90 

EQUIVALENCE  (ARGS (1 ) ,RC  (12501 ) )  ERA  100 

IF  (NARGS.EQ.O)  GO  TO  40  ERA  110 

CALL  CHKCOL  (I)  ERA  120 

IF  (I.EQ.O)  GO  TO  20  ERA  130 

1=20  ERA  140 

CALL  ERROR  (I)  ERA  150 

10        RETURN  ERA  160 

20        IF  (NERROR . NE . 0 . OR . NRMAX . EQ . 0 )  GO  TO  10  ERA  170 

DO  30  I=1,NARGS  ERA  180 

30        CALL  VECTOR  (0 . , IARGS ( I ) )  ERA  190 

GO  TO  10  ERA  200 

C  ERA  210 

C         CLEAR  ALL  OF  DIMENSIONED  WORKSHEET.  ERA  220 

C  ERA  230 

40        IF  (NERROR. NE.O)  GO  TO  10  ERA  240 

NRMAX=NROW*NCOL  ERA  250 

CALL  VECTOR  (0.,1)  ERA  260 

NRMAX=0  ERA  270 

GO  TO  10  ERA  280 

END  ERA  290 
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SUBROUTINE  ERRINT  (X  ,ERF ,ERFC) 

CDT 
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WN=WN+TWO  ERT  640 

BN=BN+F0UR  ERT  650 

PREV=F  ERT  660 

GO  TO  120  ERT  670 

160      F=PREV  ERT  680 

170      ERFC=F*FOEXP(-YSQ)*TRRTPI/TWO  ERT  690 

ERF=ONE-ERFC  ERT  700 

GO  TO  80  ERT  710 

END  ERT  720 
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SUBROUTINE  ERROR (I)  ERR  10 

C         VERSION    5.00         ERROR           5/15/70  ERR  20 

COMMON/BLOCRC/NRC.RC (12600)  ERR  30 

COMMON /BLOCKD/     IARGS(IOO) , KIND (100) ,ARGTAB(100) , NRMAX,  ERR  40 

1  NROW,NCOL ,NARGS ,VWXYZ (8) ,NERROR  ERR  50 

DIMENSION  ARGS(IOO)  ERR  60 

EQUIVALENCE  (ARGS(l) ,RC(12501) )  ERR  70 

COMMON/BLOCKC/KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST  ERR  80 

COMMON  /  BLOCKX  /  INDEX  (  6,  8  ),  LEVEL  ERR  90 

COMMON/SPRV/NERCON,NERR,ISWERR  ERR  100 

DIMENSION  IL(  2  )  ERR  110 

DATA  IBL , IL  (1 ) ,IL(2)/2H     ,2H/I,2H/F/  ERR  120 

ISCRUN=ISCRAT  ERR  130 

C  ERR  140 

C         IF      1  .LE.  I   .LE.  100,  FATAL  ERROR  ERR  150 

C         IF  101  .LE.  I   .LE.  200,  ARITHMETIC  ERROR  ERR  160 

C          IF  201  .LE.  I   .LE.            INFORMATIVE  DIAGNOSTIC  ERR  170 

C  ERR  180 

NERR=NERR+1  ERR  190 

7003     IF(  I   .GT.  100  )  GO  TO  200  ERR  200 

NERR0R=NERR0R+1  ERR  210 

WRITE(  ISCRUN,  800  )  ERR  220 

800  FORMAT (/32H***  FATAL  ERROR  IN  ABOVE  COMMAND, 52X)  ERR  230 
IF(LLIST.NE.O)  GO  TO  710  ERR  240 
WRITE(ISCRUN,700)  ERR  250 

700      FORMAT (66H***  COMMAND  WAS  NOT  LISTED  BECAUSE  NO  LIST  OR  LIST  0  WASERR  260 

1  IN  EFFECT, 18X)  ERR  270 

710  LLIST=3  ERR  280 
GO  TO  (801, 802, 803, 804, 805, 806, 807, 808, 809, 810, 811, 812, 813, 814, 815ERR  290 
1,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830),  I    ERR  300 

801  WRITE(ISCRUN,1)  ERR  310 

1  FORMAT (29H***  NAME  NOT  FOUND  IN  LIBRARY, 55X)  ERR  320 
GO  TO  900  ERR  330 

802  WRITE (ISCRUN, 2)  ERR  340 

2  FORMAT (28H***  ILLEGAL  STATEMENT  NUMBER, 56X)  ERR  350 
GO  TO  900  ERR  360 

803  WRITE(ISCRUN,3)  ERR  370 

3  FORMAT (28H***  ILLEGAL  ARGUMENT  ON  CARD,56X)  ERR  380 
GO  TO  900  ERR  390 

804  GO  TO  900  ERR  400 

805  WRITE(ISCRUN,5)  ERR  410 

5  FORMAT (38H***  COMMAND  NOT  ALLOWED  IN  REPEAT  M0DE,46X)  ERR  420 
GO  TO  900  ERR  430 

806  WRITE(ISCRUN,6)  ERR  440 

6  FORMAT (74H***  STATEMENT  NUMBER  MAY  NOT  BEGIN  ANY  CARD  BETWEEN  BEGIERR  450 
IN  AND  FINISH  CARDS, 10X)  ERR  460 

GO  TO  900  ERR  470 

807  WRITE(ISCRUN,7)  ERR  480 

7  FORMAT (23H***  ILLEGAL  *STATEMENT* ,61X)  ERR  490 
GO  TO  900  ERR  500 

808  WRITE(ISCRUN,8)  ERR  510 

8  FORMAT (34H***  PHYSICAL  CONSTANT  NOT  IN  TABLE, 50X)  ERR  520 
GO  TO  900  ERR  530 

809  WRITE(ISCRUN,9)  ERR  540 

9  FORMAT (13H***  NRMAX  -  0,71X)  ERR  550 
GO  TO  900  ERR  560 

810  WRITE(ISCRUN,10)    NARGS  ERR  570 

10  F0RMAT(3H***,I4,34H  IS  AN  ILLEGAL  NUMBER  OF  ARGUMENTS ,43X)  ERR  580 
GO  TO  900  ERR  590 
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811 

WRITE(ISCRUN,11) 

ERR  600 

11 

FORMAT (40H***  COLUMN  NUMBER  TOO  BIG  OR  LESS  THAN  1(44X) 

ERR  610 

GO  TO  900 

ERR  620 

812 

WRITE(ISCRUN(12) 

ERR  630 

12 

FORMAT (33H***  COMMAND  STORAGE  AREA  OVERFLOW, 51X ) 

ERR  640 

GO  TO  900 

ERR  650 

813 

WRITE(ISCRUN,13) 

ERR  660 

13 

FORMAT (30H***  STATEMENT  NUMBER  NOT  FOUND, 54X) 

ERR  670 

GO  TO  900 

ERR  680 

814 

WRITE(ISCRUN,14) 

ERR  690 

14 

FORMAT (35H***  ILLEGAL  OR  NO  FORMAT  DESIGNATOR ,49X) 

ERR  700 

GO  TO  900 

ERR  710 

815 

WRITE(ISCRUN,15) 

ERR  720 

15 

FORMAT (34H***  DIMENSIONED  AREA  EXCEEDS  LIMIT, 50X) 

ERR  730 

GO  TO  900 

ERR  740 

816 

WRITE(ISCRUN,16) 

ERR  750 

16 

FORMAT (27H***  ILLEGAL  SIZE  ROW  NUMBER, 57X) 

ERR  760 

GO  TO  900 

ERR  770 

817 

WRITE(ISCRUN,17) 

ERR  780 

17 

FORMAT (39H***  DEFINED  MATRIX  OVERFLOWS  WORKSHEET ,45X) 

ERR  790 

GO  TO  900 

ERR  800 

818 

WRITE(ISCRUN,18) 

ERR  810 

18 

FORMAT (36H***  INTEGER  ARGUMENT  LESS  THAN  -8191, 48X) 

ERR  820 

GO  TO  900 

ERR  830 

819 

WRITE(ISCRUN,19) 

ERR  840 

19 

FORMAT (48H***  STORED  PERFORM  STATEMENT  WILL  EXECUTE  ITSELF, 36X) 

ERR  850 

GO  TO  900 

ERR  860 

820 

WRITE(ISCRUN,20) 

ERR  870 

20 

FORMAT (29H***  IMPROPER  TYPE  OF  ARGUMENT , 55X) 

ERR  880 

GO  TO  900 

ERR  890 

821 

WRITE(ISCRUN,21) 

ERR  900 

21 

FORMAT (26H***  COMMAND  MUST  BE  STORED, 58X) 

ERR  910 

GO  TO  900 

ERR  920 

822 

WRITE(ISCRUN,22) 

ERR  930 

22 

FORMAT (31H***  MATRIX  IS  (NEARLY)  SINGULAR ,53X) 

ERR  940 

GO  TO  900 

ERR  950 

823 

WRITE(ISCRUN,23) 

ERR  960 

23 

F0RMAT(28H***INSUFFICIENT  SCRATCH  AREA,56X) 

ERR  970 

GO  TO  900 

ERR  980 

824 

WRITE(ISCRUN,24) 

ERR  990 

24 

FORMAT  (49H***  DEGREE  IS  LARGER  THAN  NO.  OF  NON-ZERO  WEIGHTS, 35X) 

ERR1000 

GO  TO  900 

ERR1010 

825 

WRITE(ISCRUN,25) 

ERR1020 

25 

FORMAT (35H***NEGAT I VE  WEIGHTS  MAY  NOT  BE  USED,49X) 

ERR1030 

GO  TO  900 

ERR1040 

826 

WRITE(ISCRUN,26) 

ERR1050 

26 

FORMAT (51H***NUMBER  OF  COLUMNS  IS  GREATER  THAN  NUMBER  OF 

R0WS,33X)ERR1060 

GO  TO  900 

ERR1070 

827 

WRITE  (ISCRUN,27) 

ERR1080 

27 

FORMAT  (19H***F0RMAT  NOT  FOUND, 65X) 

ERR1090 

GO  TO  900 

ERR1100 

c**** 

THE  FOLLOWING  CARDS  ARE  NEEDED  ONLY  FOR  TAPE  OPERATIONS 

ERR1110 

828 

WRITE(ISCRUN,28) 

ERR1120 

28 

FORMAT (47H*  INCORRECT  TAPE  UNIT.  COMMAND  IS  NOT  EXECUTED 

,37X) 

ERR1130 

GO  TO  900 

ERR1140 

'ERR1150 

829 

NSB  =  NARGS+1 

ERR1160 

WRITE  (ISCRUN ,29)  NSB 

ERR1170 

29 

FORMAT  (31H*  NUMBER  OF  ARGUMENTS  SHOULD  BE,I2,51X) 

ERR1180 
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GO  TO  900  ERR1185 

830      WRITE(ISCRUN,30)  ERR1190 

30        FORMAT  (48H*  AN  INCREMENT  COMMAND  CAN  NOT  INCREMENT  ITSELF. (36X)  ERR1200 

900  IF(  LEVEL  .NE.  0  )  CALL  RNDOWN  ERR1220 
C         FORCE  OUT  OF  REPEAT  MODE  IF  FATAL  ERROR  ERR1230 

IF(  I   .LE.  100  )  LEVEL  =  0  ERR1240 

WRITE(  ISCRUN,  901  )  ERR1250 

901  FORMAT (84X)  ERR1260 
RETURN  ERR1270 

200  IF  (NERR .LE .NERCON .OR .LLIST .NE .3 )  GO  TO  201  ERR1280 
IF(ISWERR.NE.O)  RETURN  ERR1290 
ISWERR=1  ERR1300 
WRITE(ISCRUN/9999)NERC0N  ERR1310 

9999    FORMAT (/1H*, 15, 62H  INFORMATIVE  AND  ARITHMETIC  DIAGNOSTICS  HAVE  BEEERR1320 

IN  ENCOUNTERED. ,16X/  ERR1330 
284H*    ANY  SUCH  ADDITIONAL  DIAGNOSTICS  FOR  THIS  COMMAND  OR  REPEAT  MERR1340 

30DE  ARE  DISREGARDED.   )  ERR1350 

RETURN  ERR1360 

201  IF(I.GT.200)  GO  TO  400  ERR1370 
C  ERR1380 
C  ERR1390 
C  ARITHMETIC  TROUBLES,  SET  FLAGS  ERR1400 
C  ERR1410 

CALL  AERR(I-IOO)  ERR1420 

250      RETURN  ERR1430 

C  ERR1440 

C         INFORMATIVE  DIAGNOSTIC  ERR1450 

C  ERR1460 

400      IF(  MOD(  LLIST,  2  )   .EQ.  0  )  GO  TO  250  ERR1470 

IF(LLIST.EQ.O)  GO  TO  250  ERR1475 

CALL  INFERR  (I )  ERR1480 

GO  TO  900  ERR1490 

END  ERR1500 
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SUBROUTINE  EXCHNG  EXC  10 

C         VERSION    5.00         EXCHNG         5/15/70  EXC  20 

C  EXC  30 

C         EXCHANGE  COL  ++  WITH  ++,  COL  ++  WITH  ++,  ETC.  EXC  40 

C  EXC  50 

COMMON  /BLOCRC/  NRC ,RC (12600)  EXC  60 
COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NEXC  70 

1ARGS ,VWXYZ (8) ,NERROR  EXC  80 

DIMENSION  ARGS(IOO)  EXC  90 

EQUIVALENCE  (ARGS (1) ,RC (12501) )  EXC  100 

IF  (NARGS)  70,70,10  EXC  110 

10        IF  (NARGS. NE. (NARGS/2)*2)  GO  TO  70  EXC  120 

DO  50  1=1, NARGS, 2  EXC  130 

CALL  ADRESS  (I, J)  EXC  140 

IF  (J)  60,80,20  EXC  150 

20        CALL  ADRESS  (I+l.K)  EXC  160 

IF  (K)  60,80,30  EXC  170 

30        IF  (NERROR.NE.O)  RETURN  EXC  180 

DO  40  N=l , NRMAX  EXC  190 

JJ=J+N-1  EXC  200 

KK=K+N-1  EXC  210 

WORK=RC(JJ)  EXC  220 

RC(JJ)=RC(KK)  EXC  230 

RC(KK)=WORK  EXC  240 

40        CONTINUE  EXC  250 

50        CONTINUE  EXC  260 

GO  TO  90  EXC  270 

60        CALL  ERROR  (3)  EXC  280 

GO  TO  90                                                                           .  EXC  290 

70        CALL  ERROR  (10)  EXC  300 

GO  TO  90  EXC  310 

80        CALL  ERROR  (11)  EXC  320 

90        RETURN  EXC  330 

END  EXC  340 
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SUBROUTINE  EXPAND  (J, WHERE)  EXD  10 

C         VERSION    5.00        EXPAND        5/15/70  EXD  20 

COMMON  /BLOCRC/  NRC ,RC  (12600)  EXD  30 
COMMON  /BLOCKD /  IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL (NEXD  40 

1ARGS ,VWXYZ (8) ,NERROR  EXD  50 

DIMENSION  ARGS(IOO)  EXD  60 

EQUIVALENCE  (ARGS (1) ,RC  (12501) )  EXD  70 

COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG  EXD  80 

DIMENSION  WHERE (1)  EXD  90 

C  EXD  100 

C                THIS  ROUTINE  EXPANDS  STORED  COMMANDS  FROM  WHERE  TO  A  USABLE      EXD  110 

C                FORM  IN  ARGS,  IARGS  AND  KIND.  EXD  120 

C  EXD  130 

11=0  EXD  140 

1=0  EXD  150 

JJJ=J  EXD  160 
C         CONVERT  ONLY  FIRST  ARGUMENT  IF  COMMAND  IS  INCREMENT  OR  RESTORE        EXD  170 

IF  (L1.NE.14)  GO  TO  10  EXD  180 

IF  (L2.GE.6.AND.L2.LE.8)  JJJ=2  EXD  190 

10        11=11+1  EXD  200 

20        1=1+1  EXD  210 

IF  (I.GE.JJJ)  GO  TO  80  EXD  220 

T=WHERE (I )  EXD  230 

IF  (T)  50,40,30  EXD  240 

30        KIND (I  I )=0  EXD  250 

IARGS(II)=T-8192.  EXD  260 

GO  TO  10  EXD  270 

40        KIND ( 1 1 )=1  EXD  280 

1=1+1  EXD  290 

ARGS(II)=WHERE(I)  EXD  300 

GO  TO  10  EXD  310 

50        IF(T.EQ. (-1) )  GO  TO  100  EXD  320 

CALL  XPND  (WHERE ( I ) ,K , ARGS (II) ,KND )  EXD  330 

IF  (K.GE.O)  GO  TO  90  EXD  340 

60        K=-K  EXD  350 

70       CALL  ERROR  (K)  EXD  360 

80        RETURN  EXD  370 

90        KIND(II)=KND  EXD  380 

IF  (KND.EQ.O)   IARGS(II)=ARGS(II)  EXD  390 

I=I+K  EXD  400 

GO  TO  10  EXD  410 

C  EXD  420 

C         IF  STORED  VALUE  =  -1,  THEN  ARGS  (INTEGER)  ARE  TO  BE  EXPANDED  FROM  EXD  430 

C         PREVIOUS    ARG  TO  FOLLOWING  WITH  A  MAXIMUM  TOTAL  OF  100                     EXD  440 

C  EXD  450 

100      1=1+1  EXD  460 

C         PICK  UP  NEXT  ARG  EXD  470 

IU=WHERE(I)  EXD  480 

IF  (KIND(II-l) .NE.O.OR.I .GE.J)  GO  TO  190                                             EXD  490 

IF  (IU)  170,190,110  EXD  500 

110      IU=IU-8192  EXD  510 

120      K=IU-IARGS(II-1)  EXD  520 

NARGS=NARGS+IABS (K)-l  EXD  530 

IF(NARGS.GT.IOO)  GO  TO  200  EXD  540 

IF  (K)  130,20,140  EXD  550 

130      INC=-1  EXD  560 

K=-K  N                                               EXD  570 

GO  TO  150          '  EXD  580 

140      INC=1  EXD  590 
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150 

DO  160  IT=1,K 

EXD 

600 

KIND ( 1 1 )=0 

EXD 

610 

IARGS (II )=IARGS (II-1)+INC 

EXD 

620 

160 

11=11+1 

EXD 

630 

GO  TO  20 

EXD 

640 

C 

EXD 

650 

C 

EXPAND  FORM      IARG    ***  /,ARG// 

EXD 

660 

C 

EXD 

670 

170 

CALL  XPND  (WHERE (I ) ,K,ARGS (II ) ,KND) 

EXD 

680 

IF  (K.LT.O)  GO  TO  60 

EXD 

690 

I=I+K 

EXD 

700 

IF  (KND.EQ.O)  GO  TO  180 

EXD 

710 

K=20 

EXD 

720 

GO  TO  70 

EXD 

730 

180 

IU=ARGS(II) 

EXD 

740 

GO  TO  120 

EXD 

750 

190 

CALL  ERROR  (211) 

EXD 

760 

GO  TO  10 

EXD 

770 

200 

K=10 

EXD 

780 

GO  TO  70 

EXD 

790 

END 

EXD 

800 

79 


SUBROUTINE  EXPCON 

EXN 

10 

c 

VERSION    5.00         EXPCON  5/15/70 

EXN 

20 

c 

runAAii    f  i  inn  Ai  it  T  nr       c     n>  r*  a  » f  v/              a  i  a  i  i  n 

EXPCON  SUBROUTINE    S  PEAVY  4/4/68 

r*  \t  ll 

EXN 

30 

c 

COMMANDS 

r-  w  ll 

EXN 

40 

c 

1    A       i           inip  A  A  T  A  A 

L2=l:  MVECDIA6 

EXN 

50 

c 

lll/r  AA  T  1  A           lit  TO  T  \J       T  kl      O              A           f  t  t  r      ft  1 

MVECDIAG    MATRIX  IN  R  ,  C    SIZE  N  , 

M 

O  1  1  T 

PUT 

DIAGONAL 

IN  C 

EXN 

60 

c 

iiurAn  tip        in  Tn  t  u     t  n    n           a        r  t  tt  ii 

MVECDIAG    MATRIX  IN  R  ,  C    SIZE  N  , 

M 

PUT 

DIAGONAL 

IN  R 

,  C  EXN 

70 

c 

i  a     a       inirAiii  t 

L2=2:  MVECMAT 

EXN 

80 

c 

MVECMAT      MATRIX  IN  R  ,  C    SIZE  N  , 

ll 

M 

O  1  IT 

PUT 

ROW  BY 

EXN 

90 

A 

c 

AC*  A 

AS  A 

VECTOR 

IN 

A 

c 

P°  \J  ll 

EXN 

100 

A 

c 

lit  I  r  A  111  T"             111  TO  T  V/      f||     o             A          C  T  ^  r*  ft! 

MVECMAT      MATRIX  INR,C  SIZEN, 

M 

PUT 

ROW  BY 

ROW 

1  f 

AS 

A  EXN 

110 

c 

VECTOR  IN 

R 

,  c 

EXN 

120 

A 

c 

i  a     **i        tiiii  Turn 

L2=3:  MMATVEC 

r"  \j  ii 

EXN 

130 

c 

All  A  A  Tl/TA              l/r  ATAn      A      nilT      AC      O  A  111     V/      o  O  III 

MMATVEC      VECTOR  C  PUT  AS  ROW  X  ROW 

MATRIX 

IN  R  , 

C 

SIZE 

Al              ill"  M  11 

N  ,  MEXN 

135 

c 

AAAA  IT\/TA               I  f  F  A  T  A  0.      O               A      ni  IT       If      O  /\  111  W 

MMATVEC      VECTOR  R   ,  C  PUT  AS  ROW  X 

ROW  MATRIX  IN 

R 

A 

,  c 

run 

EXN 

1     1  A 

140 

A 

c 

SIZE 

N  X  M 

EXN 

145 

COMMON  /BL0CRC/  NRC ,RC  (12600) 

EXN 

160 

COMMON  /BL0CKD /  IARGS(IOO) ,KIND(100) ,ARGTAB (100) ,NRMAX ,NR0W,NC0L ,NEXN 

170 

1  ARK*;  VWYY7rfl\  NFRROR 

U  AM 

180 

CAN 

190 

EQUIVALENCE  (ARGS (1 ), RC (12501 ) ) 

LAn 

200 

COMMON  /SCRAT/  NS,NS2 ,A(13500) 

u  All 

210 

COMMON  /BL0CKE/  NAME (4) ,L1 ,L2 , ISRFLG 

CAN 

220 

IF  (NARGS.EQ.5.0R.NARGS.EQ.6)  GO  TO  10 

can 

A  A 

230 

CALL  ERROR  (10) 

F¥  M 
C  All 

AAA 

240 

RETURN 

LAN 

250 

10 

J=NARGS 

rvM 
t  AN 

260 

KRR=0 

CAN 

270 

CALL  CKIND  (J) 

ryu 
LAN 

280 

IF  (J.EQ.0)     IF  (L2-2)  15,65,125 

cyu 
LAN 

285 

CALL  ERROR  (3) 

ruM 

LAN 

290 

RETURN 

LAN 

300 

c 

VEC  DIAG  **** 

ryu 

LAN 

310 

15 

I ARGS (7 )=MIN0 ( IARGS (3 ) , IARGS (4) ) 

LAN 

320 

IARGS(8)=1 

ryu 

LAN 

O  A  A 

330 

IF  (NARGS.EQ.6)  GO  TO  20 

EXN 

340 

IARGS(6)=IARGS(5) 

r*  v  ai 

EXN 

350 

IARGS(5)=1 

IT  V  Al 

EXN 

360 

MKKR=226 

C  V  Al 

EXN 

1  "T  A 

370 

20 

IF  (IARGS(5)+IARGS(7)-1.LE.NR0W)  GO  TO  30 

C  V  Al 

EXN 

1  A  A 

380 

IARGS(7)=NR0W-IARGS(5)+1 

EXN 

390 

KRR=MKKR 

EXN 

400 

A 

c 

ERROR  226:  COLUMN  NOT  LONG  ENOUGH  TO  STORE 

ALL 

ELEMENTS. 

ONLY 

NR0WEXN 

A  1  A 

410 

c 

WILL  BE  STORE 

EXN 

420 

30 

J=2 

EXN 

430 

CALL  MTXCHK  (J) 

EXN 

440 

IF  (J.NE.0)  CALL  ERROR  (17) 

EXN 

A  F  A 

450 

IF  (NERR0R.NE.0)  RETURN 

EXN 

A  £  A 

460 

IF  (KRR.NE.0)  CALL  ERROR  (KRR) 

EXN 

470 

GO  TO  (40,80,140) ,  L2 

EXN 

4  A  A 

480 

40 

IA=IARGS(1) 

EXN 

i  AA 

490 

IB=IARGS(7) 

EXN 

p  A  A 

50© 

DO  50  1=1, IB 

EXN 

p  1  A 

510 

A(I j-RC(IA) 

EXN 

p  A  A 

520 

50 

IA=IA+NR0W+1 

EXN 

530 

IA=IARGS(5) 

EXN 

C  A  A 

540 

DO  60  1=1, IB 

EXN 

IT  B  A 

550 

RC(IA)=A(I) 

EXN 

p/A 

560 

60 

I A=I A+l 

EXN 

570 

80 


RETURN 

EXN  580 

c 

65    VECTORIZE  A  MATRIX  *** 

EXN  590 

65 

IARGS(7)=IARGS(3)*IARGS(4) 

EXN  600 

IARGS(8)=1 

EXN  610 

IF  (NARGS.EQ.6)  GO  TO  70 

EXN  620 

IARGS(6)=IARGS(5) 

EXN  630 

IARGS(5)=1 

EXN  640 

70 

MKKR=226 

EXN  650 

GO  TO  20 

EXN  690 

80 

IB=IARGS(7) 

EXN  700 

IA=IARGS(1) 

- 

EXN  710 

N=IARGS(3) 

EXN  720 

M=I ARGS (4 ) 

EXN  730 

IC=1 

EXN  740 

DO  100  1=1 ,N 

EXN  750 

IAA=IA 

EXN  760 

DO  90  J=1,M 

EXN  770 

A(IC)=RC(IAA) 

EXN  780 

IF  (IC.EQ.IB)  GO  TO  110 

EXN  790 

IC=IC+1 

EXN  800 

90 

IAA=IAA+NROW 

EXN  810 

100 

IA=IA+1 

EXN  820 

110 

IA=IARGS(5) 

EXN  830 

DO  120  1=1, IB 

EXN  840 

RC(IA)=A(I) 

EXN  850 

120 

IA=IA+1 

EXN  860 

RETURN 

EXN  870 

C 

125  TAKE  A  COLUMN  AND  RESTORE  IT 

TO 

A 

MATRIX  OR  ARRAY. 

EXN  880 

125 

IARGS (8)=IARGS(NARGS) 

EXN  890 

IARGS(7)=IARGS(NARGS-1) 

EXN  900 

IARGS (6 )=I ARGS (NARGS-2 ) 

EXN  910 

IARGS(5)=IARGS(NARGS-3) 

EXN  920 

IF  (NARGS.EQ.6)  GO  TO  130 

EXN  930 

IARGS(2)=IARGS(1) 

EXN  940 

IARGS(1)=1 

EXN  950 

130 

IARGS(3)=IARGS(7)*IARGS(8) 

EXN  960 

IARGS(4)=1 

EXN  970 

IF  (IARGS(1)+IARGS(3)-1.LE 

NROW) 

GO 

TO 

30 

EXN  980 

IARGS (3 )=NROW-I ARGS ( 1 ) +1 

EXN  990 

C 

KRR=227 

EXN1000 

C 

227  ERROR: /NOT  ENOUGH  ELEMENTS  IN  COL 

TO  RESTORE  MATRIX  OR  ARRAY. 

EXN1010 

C 

ELEMENTS  AVAILABLE  WILL  BE 

USED. 

EXN1020 

GO  TO  30 

EXN1030 

140 

IA=IARGS (1) 

EXN1040 

IB=IARGS(3) 

EXN1050 

DO  150  1=1, IB 

EXN1060 

A(I)-RC(IA) 

EXN1070 

150 

IA=IA+1 

EXN1080 

IA=IARGS(5) 

EXN1090 

N=IARGS(7) 

EXN1100 

M=IARGS(8) 

EXN1110 

IC=1 

EXN1120 

DO  170  1=1, N 

EXN1130 

IAA=IA 

EXN1140 

DO  160  J=1,M 

EXN1150 

RC(IAA)=A(IC) 

EXN1160 

IF  (IC.EQ.IB)  RETURN 

EXN1170 

IC-IC+1 

EXN1180 

160 

IAA-IAA+NROW 

EXN1190 

170 

IA=IA+1 

EXN1200 

RETURN 

EXN1210 

END 

81 

EXN1220 

CIIDDHIITTMr  CVTDCU 
bUDKUUIlNL   LA  1 KLM 

C  VT 
t  A  1 

1  A 
10 

L 

WCDCTAM      C    AA              CVTBFU  C/1C/7A 

CVT 
LA  1 

9  A 
(JO 

COMMON  /BLOCRC/  NRC , RC  ( 12600 ) 

EXT 

1  A 

COMMON  /BLOCKD/  IARGS (100) , KIND (100) ,ARGTAB (100 ) ,NRMAX ,NR0W,NC0L , NEXT 

A  A 

1ARGS,VWXYZ(8) ,NERR0R 

FYT 

CA  1 

C  A 

DIMENSION  ARGS(100) 

fyt 

LA  1 

L  A 

60 

EQUIVALENCE 

(ARGS(l) ,RC(12501) ) 

FYT 

LA  1 

7  A 

COMMON  /BL0CKE/  NAME (4) ,L1 ,L2 , ISRFLG 

FYT 

LA  1 

a  a 

p 

FYT 

LA  1 

OA 
7U 

p 

L2  =  4,5  MAX 

L2  =  6,7  MIN 

FYT 

LA  1 

1  AA 

p 

FYT 

LA  1 

I  1  A 

I I  u 

p 

MAX  OF  ++  TO 

++ 

FYT 

LA  1 

1  c  U 

p 

MAX  OF  ++  TO 

++,  CORRESP  ENTRY  OF  ++  TO  ++, 

.  .   TP.    ,  ,  CTP 

++     1 v    ++ ,  Lib. 

FYT 

LA  1 

1  1  A 

p 

LIKEWISE  FOR 

MIN. 

FYT 

LA  1 

1  A  A 

p 

FYT 

LA  1 

i 

13U 

IF  (NARGS.GT 

. 0 .AND . MOD (NARGS , 2 ) . EQ . 0 )  GO  TO 

in 

FYT 

LA  1 

1  L  A 

1=10 

FYT 

LA  1 

1  7  A 

i  a 

CALL  ERROR  (I) 

FYT 

LA  1 

i  on 

9  n 

RETURN 

FYT 

LA  1 

1  OA 

in 

CALL  CHKC0L 

(I) 

EYT 

CA  1 

o  no 

IF  (I.EQ.0) 

GO  TO  40 

EYT 

CA  1 

1 1  A 

L  1U 

1=20 

EXT 

CA  1 

1 1  A 

GO  TO  10 

EXT 

CA  1 

tin 

An 

IF  (NERROR.NE.O)  GO  TO  20 

EXT 

CA  1 

9  AA 

J=0 

EXT 

CA  1 

IF  (NRMAX-1) 

50,110,60 

EXT 

CA  1 

COM 

1=9 

EXT 

CA  1 

L  I  U 

GO  TO  10 

FXT 

CA  1 

3QA 

OU 

J=IARGS(1) 

FXT 

CA  1 

9QA 

K=J+1 

EXT 

CA  1 

inn 

L=K+NRMAX-2 

EXT 

CA  1 

n  n 

IF  (L2.GT.5) 

GO  TO  80 

EXT 

CA  1 

ion 
i  c.  u 

p 

EXT 

CA  1 

nn 

P 

FIND  MAXIMUM 

FXT 

CA  1 

7  An 

p 

EXT 

CA  1 

i^n 

DO  70  I=K,L 

EXT 

CA  1 

i  An 

IF  (RC(J).LT 

.RC(I))  J=I 

FXT 

LA  1 

.?  /  u 

CONTINUE 

EXT 

CA  1 

5Qft 

GO  TO  100 

EXT 

CA  1 

ion 

p 

EXT 

CA  1 

Ann 

p 

FIND  MINIMUM 

FXT 

LA  1 

A  1  A 

p 

FXT 

LA  1 

a?  n 

a  a 

DO  90  I=K,L 

EXT 

CA  1 

Ain 

IF  (RC(J).GT 

.RC(I))  J=I 

FXT 

LA  1 

AAn 

CONTINUE 

FYT 

LA  1 

A^n 

1  AA 

J=J-IARGS(1) 

FYT 

LA  1 

AAn 

1  1  A 

DO  120  I=1,NARGS,2 

EXT 

A7n 

K=IARGS(I)+J 

EXT 

Ann 

1  A 

120 

CALL  VECTOR 

(RC(K) ,IARGS(I+1)) 

EXT 

Aon 

GO  TO  20 

EXT 

cnn 

END 

EXT 

510 

82 


FUNCTION  FCOS  (X) 

FCO 

10 

c 

VERSION  5.00  FCOS  5/15/70 

FCO 

20 

c 

FCO 

30 

c 

THIS  FUNCTION  IS  TO  TRAP  IF  ARGUMENT  IS 

GREATER  THAN  3.3E7  IN 

FCO 

40 

c 

ABSOLUTE  VALUE  BEFORE  SYSTEM  DOES.  RESULT  SET  =0.0 

FCO 

50 

c 

FCO 

60 

COMMON  /CONSLB/  XTRIG,XEXP 

FCO 

70 

IF  (ABS(X) .GT.XTRIG)  GO  TO  20 

FCO 

80 

FCOS=COS(X) 

FCO 

90 

10 

RETURN 

FCO 

100 

20 

CALL  ERROR  (104) 

FCO 

110 

FCOS=0. 

FCO 

120 

GO  TO  10 

FCO 

130 

END 

FCO 

140 

DOUBLE  PRECISION  FUNCTION  FDCOS(X) 

FDC 

10 

C 

VERSION    5.00         FDCOS  5/15/70 

FDC 

20 

C 

FDC 

30 

c 

THIS  FUNCTION  IS  TO  TRAP  IF  ARGUMENT  IS 

GREATER  THAN    3.5016  IN 

FDC 

40 

c 

ABSOLUTE  VALUE  BEFORE  SYSTEM  DOES.  RESULT  SET  =0  WITH  DIAGNOSTIC. 

FDC 

50 

c 

FDC 

60 

DOUBLE  PRECISION  DSNCOS,DXEXP 

FDC 

70 

COMMON  /DCONLB/  DSNCOS,DXEXP 

FDC 

80 

DOUBLE  PRECISION  X,DCOS 

FDC 

90 

IF  (DABS(X) .GT.DSNCOS)  GO  TO  20 

FDC 

100 

FDCOS=DCOS(X) 

FDC 

110 

10 

RETURN 

FDC 

120 

20 

CALL  ERROR  (104) 

FDC 

130 

FDCOS=O.DO 

FDC 

140 

GO  TO  10 

FDC 

150 

END 

FDC 

160 

DOUBLE  PRECISION  FUNCTION  FDEXP  (X) 

FDE 

10 

C 

VERSION    5.00         FDEXP  5/15/70 

FDE 

20 

C 

FDE 

30 

C 

THIS  FUNCTION  IS  TO  TRAP  IF  ARGUMENT  IS 

GREATER  THAN  704. DO 

FDE 

40 

C 

BEFORE  SYSTEM  DOES.  RESULT  IS  SET  =0.0 

AND  DIAGNOSTIC  IS  PRINTED 

.FDE 

50 

c 

FDE 

60 

DOUBLE  PRECISION  DSNCOS(DXEXP 

FDE 

70 

COMMON  /DCONLB/  DSNCOS,DXEXP 

FDE 

80 

DOUBLE  PRECISION  X,DEXP 

FDE 

90 

IF  (X.GT.DXEXP)  GO  TO  20 

FDE 

100 

FDEXP=DEXP(X) 

FDE 

110 

10 

RETURN 

FDE 

120 

20 

CALL  ERROR  (102) 

FDE 

130 

FDEXP=0.0D0 

FDE 

140 

GO  TO  10 

FDE 

150 

END 

FDE 

160 

83 


DOUBLE  PRECISION  FUNCTION  FDLOG(X)  FDL  10 

C         VERSION    5.00         FDLOG           5/15/70  FDL  20 

C  FDL  30 

C         THIS  FUNCITON  IS  TO  TRAP  ILLEGAL  ARGUMENT  FDL  40 

C         BEFORE  SYSTEM  DOES.     RESULT  SET  0.0  AND  DIAGNOSTIC  IS  PRINTED  FDL  50 

C  FDL  60 

DOUBLE  PRECISION  X,DLOG  FDL  70 

IF  (X.GT.O.DO)  GO  TO  10  FDL  80 

CALL  ERROR  (101)  FDL  90 

FDLOG=O.DO  FDL  100 

GO  TO  20  FDL  110 

10        FDLOG=DLOG (X)  FDL  120 

20        RETURN  FDL  130 

END  FDL  140 


FUNCTION  FDPCON  (X)  FDP  10 

C         VERSION    5.00         FDPCON         5/15/70  FDP  20 

C         WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS .      8/16/69.  FDP  40 

DOUBLE  PRECISION  X,D  FDP  50 

Y=X  FDP  60 

D=Y  FDP  70 

FDPCON=X+(X-D)  FDP  80 

RETURN  FDP  90 

END  FDP  100 


DOUBLE  PRECISION  FUNCTION  FDSIN(X)  FDS  10 

C         VERSION    5.00         FDSIN           5/15/70  FDS  20 

C  FDS  30 

C         THIS  FUNCITON  IS  TO  TRAP  IF  ARGUMENT  IS  GREATER  THAN  3.5D16  IN        FDS  40 

C         ABSOLUTE  VALUE  BEFORE  SYSTEM  DOES.  RESULT  SET  =0.0                          FDS  50 

C  FDS  60 

DOUBLE  PRECISION  DSNCOS,DXEXP  FDS  70 

COMMON  /DCONLB/  DSNCOS.DXEXP  FDS  80 

DOUBLE  PRECISION  X.DSIN  FDS  90 

IF  (DABS(X) .GT.DSNCOS)  GO  TO  20  FDS  100 

FDSIN=DSIN(X)  FDS  110 

10        RETURN  FDS  120 

20        CALL  ERROR  (104)  FDS  130 

FDSIN=O.DO  FDS  140 

GO  TO  10  FDS  150 

END  FDS  160 
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DOUBLE  PRECISION  FUNCTION  FOSQRT  (X)                                                   FDQ  10 

C         VERSION    5.00         FOSQRT         5/15/70  FDQ  20 

C  FDQ  30 

C         THIS  FUNCTION  TRAPS  IF  ARGUMENT  IS  NEGATIVE  BEFORE  SYSTEM  DOES.      FDQ  40 

C         RESULT    SET  =0.0  AND  DIAGNOSTIC  IS  PRINTED                                       FDQ  50 

C  FDQ  60 

DOUBLE  PRECISION  X.DSQRT  FDQ  70 

IF  (X.LT.O.DO)  GO  TO  10  FDQ  80 

FDSQRT=DSQRT (X)  FDQ  90 

RETURN  FDQ  100 

10        CALL  ERROR  (101)  FDQ  110 

FDSQRT=0 .DO  FDQ  120 

RETURN  FDQ  130 

END  FDQ  140 


FUNCTION  FEXP  (X)  FEX  10 

C         VERSION    5.00         FEXP  5/15/70                                                   FEX  20 

C  FEX  30 

C         THIS  FUNCTION  IS  TO  TRAP  IF  ARGUMENT  IS  GREATER  THAN    88.0  BEFORE  FEX  40 

C         SYSTEM  DOES.  RESULT    SET  =0.0.  FEX  50 

C  FEX  60 

COMMON  /CONSLB/  XTRIG,XEXP  FEX  70 

IF  (X.GT.XEXP)  GO  TO  20  FEX  80 

FEXP=EXP(X)  FEX  90 

10        RETURN  FEX  100 

20       CALL  ERROR  (102)  FEX  110 

FEXP=0.  FEX  120 

GO  TO  10  FEX  130 

END  FEX  140 


FUNCTION  FEXP2  (B,E)  FX2  10 

C         VERSION    5.00         FEXP2  5/15/70                                                   FX2  20 

DATA  IEXP/60/  FX2  30 

C  FX2  40 
C         THIS  FUNCTION  IS  INCLUDED  TO  CATCH  EXPONENTIATION  ERRORS  BEFORE      FX2  50 

C         THE  SYSTEM  DOES  FX2  60 

C  FX2  70 

IE=E  FX2  80 

IF  (E.EQ.FLOAT(IE) .AND . IE .LT . IEXP)  GO  TO  20  FX2  90 

FEXP2=FEXP(E*FL0G(B))  FX2  100 

10        RETURN  FX2  110 

20        FEXP2=B**IE  FX2  120 

GO  TO  10  FX2  130 

END  FX2  140 
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SUBROUTINE  FIXFLO  FIX  10 

C         VERSION    5.00         FIXFLO         5/15/70  FIX  20 

COMMON  /ABCDEF /  L(48)  FIX  30 

COMMON  /BLOCRC/  NRC ,RC  (12600)  FIX  40 
COMMON  /BLOCKD /  IARGS(IOO) ( KIND (100) , ARGTAB (100 ) ,NRMAX ,NROW,NCOL (NFIX  50 

1ARGS ,VWXYZ (8) ,NERROR  FIX  60 

DIMENSION  ARGS(IOO)  FIX  70 

EQUIVALENCE  (ARGS (1 ) ,RC (12501 ) )  FIX  80 

COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG  FIX  90 

C0MM0N/C0NLB2/ER,ISIGD  FIX  95 

COMMON  /FMAT /  IFMTX (6 ) , IOSWT , IFMTS (6 ) , LHEAD (96 )  FIX  100 

DIMENSION  IB (3 )  FIX  110 

DATA  IB(1),IB(2),IB(3)/2H8F,2H8E,2H1P/  FIX  120 

C  FIX  130 

C         L2  =  3  FOR  FIXED,  L2  =  4  FOR  FLOAT  FIX  140 

C         L2=12    FOR    FLEXIBLE  FIX  150 

C  FIX  160 

IF  (L2.NE.12)  GO  TO  5  FIX  170 

IOSWT=0  FIX  180 

RETURN  FIX  190 

5          IF  (L2.NE.4.0R.NARGS.NE.0)    GO  TO  8  FIX  192 

1=6  FIX  194 

GO  TO  50  FIX  196 

8          IF  (NARGS.EQ.l)  IF  (KIND(l))  30,40,30  FIX  198 

1=10  FIX  200 

10       CALL  ERROR  (I)  FIX  210 

20       RETURN  FIX  220 

30        1=20  FIX  230 

GO  TO  10  FIX  240 

40        I=IARGS(1)  FIX  250 

IF (I .GE.O.AND.I .LE.ISIGD)  GO  TO  50  FIX  260 

I=ISIGD  FIX  270 

CALL  ERROR  (237)  FIX  280 

50        I0SWT=1  FIX  290 

IFMTX(5)=L(I+1)  FIX  300 

IF  (L2.EQ.4)  GO  TO  60  FIX  310 

C         SET  UP  FIXED  FORMAT  FIX  320 

IFMTX(3)=IB(1)  FIX  330 

IFMTX(2)=L(45)  FIX  340 

RETURN  FIX  350 

C         SET  UP  FLOATING  FORMAT  FIX  360 

60        IFMTX(3)=IB(2)  FIX  370 

IFMTX(2)=IB(3)  FIX  380 

RETURN  FIX  390 

END  FIX  400 
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c 
c 
c 
c 


10 
20 
30 


40 
50 
60 


70 
80 

C 
C 
C 

90 


100 
110 


SUBROUTINE  FLIP 

VERSION    5.00         FLIP  5/15/70 
COMMON  /BLOCRC/  NRC  , RC  ( 12600 ) 

COMMON  /BLOCKD /  IARGS(IOO) ,KIND(100) , ARGTAB ( 100 ) , NRMAX , NROW , NCOL , N 
IARGS, VWXYZ(8) ,NERROR 
DIMENSION  ARGS(IOO) 
EQUIVALENCE  (ARGS (1 ), RC  (12501 ) ) 

EQUIVALENCE  (I ,  IARGS  (100) ) ,  ( J , IARGS (99 ) ) ,  (K , IARGS (98 ) ) ,  (KK , IARG 
1S(97)),  (M,IARGS(96)) ,  (MM, IARGS (95 )) ,  (MMM, IARGS (94 )) ,  (N,IARGS(9 
23)),   (NN,IARGS(92) ) ,  (A,ARGS(1)) 

FLIP  COL  ++  INTO  COL  ++,  ++  INTO  ++,  ETC. 

IF  NARGS  =  0,  FLIP  THE  ENTIRE  ARRAY  (WORKSHEET). 

IF  (NARGS. EQ.O)  GO  TO  40 

IF  (MOD (NARGS, 2) .EQ.O)  GO  TO  30 

1=10 

CALL  ERROR  (I) 
RETURN 

CALL  CHKCOL  (I) 

IF  (I. EQ.O)  GO  TO  40 

1=20 

GO  TO  10 

IF  (NERROR.NE.O)  GO  TO  20 
IF  (NRMAX-1 )  50,20,60 
1=9 

GO  TO  10 

KK=NRMAX-1 

K=KK/2 

IF  (NARGS. EQ.O)  GO  TO  90 

DO  80  1=1 , NARGS , 2 

M=IARGS(I) 

N=IARGS(I+1) 

MM=M+KK 

NN=N+KK 

DO  70  J=M,MMM 

A=RC(J) 

RC(N)=RC(MM) 

RC(NN)=A 

N=N+1 

MM-^MM— \ 

NN-NN-l 

CONTINUE 

GO  TO  20 

FLIP  ENTIRE  ARRAY 

N=l 

DO  110  1=1, NCOL 
M=N 

MM=M+KK 
DO  100  J=1,K 
A=RC(M) 
RC(M)=RC(MM) 
RC(MM)-A 
M=M+1 
MM* MM- 1 
N=N+NROW 
GO  TO  20 
END 
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10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
180 
190 
200 
210 
220 
230 
240 
250 
260 
270 
280 
290 
300 
310 
320 
330 
340 
350 
360 
370 
380 
390 
400 
410 
420 
430 
440 
450 
460 
470 
480 
490 
500 
510 
520 
530 
540 
550 
560 
570 
580 
590 
600 
610 


FUNCTION  FLOG  (X) 
C         VERSION    5.00         FLOG  5/15 
C         FLOG  CHECKS  TO  SEE  IF  ARGUMENT  IS 
C         LIBRARY  FUNCTION  FOR  NATURAL  LOG. 
C         IF  X  IS  ZERO  OR  NEG.,  RESULT  IS  = 

IF  (X.GT.O.)  GO  TO  10 

CALL  ERROR  (101) 

FLOG=0 . 

GO  TO  20 
10       FLOG=ALOG (X) 
20  RETURN 

EM 


FLE  10 

70                                                    FLE  20 

GREATER  THAN  0,  BEFORE  USING       FLE  23 

FLE  25 

0  AND  DIAGNOSTIC  IS  PRINTED.        FLE  27 

FLE  30 

FLE  40 

FLE  50 

FLE  60 

FLE  70 

FLE  80 

FLE  90 


FUNCTION  FL0G10  (X)                                                                             FLT  10 

C         VERSION    5.00  FL0G10         5/15/70                                                    FLT  20 

C  FLT  30 
C         THIS  FUNCTION  CHECKS  TO  SEE  IF    X  IS  ZERO  OR  NEGATIVE  BEFORE  USINGFLT  40 

C         LIBRARY    AL0G10.  INFORMATIVE  DIAGNOSTIC  IS  PRINTED  AND  0  RETURNED. FLT  50 

C  FLT  60 

IF  (X.GT.O.O)  GO  TO  20  FLT  70 

CALL  ERROR  (101)  FLT  80 

FL0G10=0.0  FLT  90 

10       RETURN  FLT  100 

20       FL0G10=AL0G10(X)  FLT  110 

GO  TO  10  FLT  120 

El\JD  FLT  130 
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SUBROUTINE  FNEC  FNE  10 

C  VERSION  5.00  FNEC  5/15/70  FNE  20 
C  THIS  SUBROUTINE  HANDLES  MISC  FUNCTION  COMMANDS  WITH  TWO  ARGUMENTS , FNE  30 
C         THE  FIRST  IS  (E)   (A  CONSTANT,  OR  COLUMN  NUMBER)  AND  THE  SECOND  IS  FNE  40 

C          (C)     A  COLUMN  NUMBER  FNE  50 

C         WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS .      3/27/70.  FNE  60 
COMMON  /BLOCKD /  I ARGS (100) ,KIND (100 ) , ARGTAB (100 ) ,NRMAX ,NROW,NCOL ,NFNE  70 

1ARGS,VWXYZ(8) ,NERROR  FNE  80 

COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG  FNE  90 

COMMON  /BLOCRC/  NRC  ,RC  (12600)  FNE  100 

DIMENSION  ARGS(IOO)  FNE  110 

EQUIVALENCE  (ARGS (1 ) ,RC  (12501 ) )  FNE  120 

COMMON  /SCRAT/  NS ,NS2 (A  (13500)  FNE  130 

DOUBLE  PRECISION  Y,Z  FNE  140 

C         *****  COMMANDS  *****  FNE  150 

C         ERROR     (E),   (C)  L2=18      BY  I.  STEGUN ,  3/25/70.  FNE  160 

C         CERF      (E),   (C)  L2=19      BY  I.  STEGUN,  3/25/70.  FNE  170 

C         *****  FNE  180 

10        IF  (NARGS.NE.2)  CALL  ERROR  (10)  FNE  190 

IF  (NRMAX.EQ.O)  CALL  ERROR  (9)  FNE  200 

CALL  ADRESS  (1,J1)  FNE  210 

IF  (Jl.LT.O)  J1=-J1  FNE  220 

IF  (Jl.EQ.O)  CALL  ERROR  (11)  FNE  230 

CALL  ADRESS  (2,J2)  FNE  240 

IF  (J2.EQ.0)  CALL  ERROR  (11)  FNE  250 

IF  (J2.LT.0)  CALL  ERROR  (20)  FNE  260 

IF  (NERROR.NE.O)  GO  TO  70  FNE  270 

LL=L2-17  FNE  280 

DO  60  I=1,NRMAX  FNE  290 

IF  (KIND(l) .EQ.l.AND.I .GT.l)  GO  TO  50  FNE  300 

GO  TO  (20,30)  ,  LL  FNE  310 

20       CALL  ERRINT  (DBLE (RC ( Jl ) ) , Y ,Z)  FNE  320 

X=FDPCON(Y)  FNE  330 

GO  TO  40  FNE  340 

30       CALL  ERRINT  (DBLE (RC (Jl) ) ,Z,Y)  FNE  350 

X=FDPCON(Y)  FNE  360 

GO  TO  40  FNE  370 

40       J1=J1+1  FNE  380 

50        RC(J2)=X  FNE  390 

60       J2=J2+1  FNE  400 

70        RETURN  FNE  410 

END  FNE  420 
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SUBROUTINE  FNEIC  FNC  10 

C         VERSION    5.00         FNEIC         5/15/70  FNC  20 

C         THIS  SUBROUTINE  HANDLES  INSTRUCTIONS  OF  THE  FORM  (E),   (I),   (C)        FNC  30 

C         WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS.  4/21/70.                                     FNC  40 

C         *****  COMMON  *****  FNC  50 

COMMON  /BLOCKD /  I ARCS (100) , KIND (100) , ARGTAB (100 ) ,NRMAX , NROW.NCOL ,NFNC  60 

1ARGS ,VWXYZ (8) ,NERROR  FNC  70 

COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG  FNC  80 

COMMON  /BLOCRC/  NRC ,RC (12600)  FNC  90 

DIMENSION  ARGS(IOO)  FNC  100 

EQUIVALENCE  (ARGS (1) ,RC  (12501) )  FNC  110 

COMMON  /SCRAT/  NS ,NS2 ,A  (13500)  FNC  120 

C         *****  FNC  130 

IF  (NRMAX.EQ.O)  CALL  ERROR  (9)  FNC  140 

IF  (NARGS.NE.3)  CALL  ERROR  (10)  FNC  150 

IF  (KIND(2) .NE.O)  CALL  ERROR  (20)  FNC  160 

CALL  ADRESS  (1,J)  FNC  170 

IF  (J.LT.O)  J=-J  FNC  180 

CALL  ADRESS  (3,K)  FNC  190 

IF  (J.EQ.O.OR.K.EQ.O)  CALL  ERROR  (11)  FNC  200 

IF  (K.LT.O)  CALL  ERROR  (20)  FNC  210 

IF  (NERROR.NE.O)  RETURN  FNC  220 

N=IARGS(2)  FNC  230 

DO  10  I=1,NRMAX  FNC  240 

C         ROUND  X  EQUAL  TO  (E)  TO  (I)  SIGNIFICANT  DIGITS,  PUT  IN  COLUMN  (C)  FNC  250 

C         SUBROUTINE  TO  ROUND.  WRITTEN  BY  DAVID  HOGBEN,  SEL,  NBS.     10/21/68. FNC  260 

CALL  DHRND  (RC (J ) ,N ,RC (K) )  FNC  270 

IF  (KIND(l) .EQ.O)  J=J+1  FNC  280 

10        K=K+1  FNC  290 

RETURN  FNC  300 

END  FNC  310 


90 


c 
c 
c 
c 


c 

10 


FNKC 

00         FNKC  5/15/70 

TREATS  INSTRUCTIONS  OF  THE  FORM  (K) 

DAVID  HOGBEN,  SEL,  NBS .  4/22/70. 


(C) 


***** 


SUBROUTINE 
VERSION  5 
SUBROUTINE 
WRITTEN  BY 
*****  COMMON 

COMMON  /BLOCKD /  IARGS (100) , KIND (100) ,ARGTAB(100) ,NRMAX ,NROW,NCOL , 
1ARGS,VWXYZ(8) ,NERROR 
COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG 
COMMON  /BLOCRC/  NRC ,RC  (12600) 
DIMENSION  ARGS(IOO) 
EQUIVALENCE  (ARGS (1 ), RC (12501 ) ) 
COMMON  /SCRAT/  NS  ,NS2 ,A (13500) 


FKC 
FKC 
FKC 
FKC 
FKC 
NFKC 
FKC 
FKC 
FKC 


***** 


RETURN 


(9) 
(10) 


IF  (L1.NE.24.0R.L2.NE.15) 
CALL  ERROR  (235) 

F  (NRMAX.EQ.O)  CALL  ERROR 

F  (NARGS.NE.2)  CALL  ERROR 
CALL  ADRESS  (2, J) 

F  (J.EQ.O)  CALL  ERROR  (11) 

F  (J.LT.O)  CALL  ERROR  (20) 

F  (NERROR.NE.O)  RETURN 
NST=ARGS(1) 

F  (NST.LE.O)  NST=8192.0*ARGS(1)+0.1 

F  (KIND(l) .EQ.O)  NST=IARGS(1) 
NST=M0D(NST,8192) 
DO  10  1=1 ,NRMAX 

RNJBK  SHOULD  BE  REPLACED  BY  MORE  RELIABLE 

CALL  RNJBK  (RC (J ) ,NST ,NST) 

J=J+1 

RETURN 

END 


AND  EFFICIENT  GENERATOR 
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20 
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40 
50 
60 
70 
80 
90 


FKC  100 
FKC  110 
FKC  120 
FKC  130 
FKC  140 
FKC  150 
FKC  160 
FKC  170 
FKC  180 
FKC  190 
FKC  200 
FKC  210 
FKC  220 
FKC  230 
FKC  240 
FKC  250 
FKC  260 
FKC  270 
FKC  280 
FKC  290 
FKC  300 
FKC  310 
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n  inn  ai  it  t  ti  r     rAi  in  ?  a       /  \t      a     r>     >i     1/  a  a  v 

SUBROUTINE  FOURIA  (Y , A ,R ,N ,KAA) 

F0U 

10 

VERSION    5.00         FOURIA  5/15/70 

F0U 

20 

nnuni  r    nnPATCT^Ai    \j  /  t  \     r\  /  t  \     a     a  a     ad     *  n    n  a     n  n  An 

DOUBLE  PRECISION  Y ( 1 ) ,R (1 ) , A , AA , AB , AC ,BA ,BB , AD 

PAH 

F0U 

30 

DOUBLE  PRECISION  FDC0S,FDSIN 

FOU 

40 

M=N/2 
K=2*M 

FOU 

50 

FOU 

60 

L=0 

FOU 

70 

TP       /Al          A      U  \       A  A      T  A      1  A 

IF  (N.EQ.K)  GO  TO  10 

rni  i 

FOU 

80 

L=l 

PAI 1 

FOU 

A  A 

90 

An  ai 

AB=N 

PAI  1 

FOU 

i  nn 

100 

A    A           X           AAAIAF'AA'Vm^nA      1    A  n 

AA=6 .283 185307 1700/ AB 

1"  A  1  1 

FOU 

110 

A=0  .0 

r  ai  i 

FOU 

120 

n  /|i>  a 

R (M)=.0 

PAII 

FOU 

130 

a  a  « 

AC=1 . 

taii 

FOU 

140 

|N  f\      a  f\      T       <»  Al 

DO  20  1=1 , N 

PAI  1 

FOU 

150 

A       A      \J  I  T  \ 

A=A+Y ( I ) 

PAII 

FOU 

160 

n  1  AA  \       n  /  AA  \       1  AiU  /  T  v 

R (M)=R (M)+AC*Y (I ) 

PAII 

FOU 

170 

A  A         ^      i in 

AC=-1 .  AC 

PAII 

FOU 

180 

A      i  jin 

A=A /AB 

PAI  1 

FOU 

1  A  A 

190 

D  /  Afl  \      D/Al\  /AD 

K (M)=R (M) /AB 

PAI  1 

FOU 

AAA 

200 

1       AA     1  ^ 

J=M+L-1 

PAI  I 

FOU 

210 

1/  A       AA  ^ 

KA=M+1 

PAII 

FOU 

220 

f\  A      A  A     1/      1  1 

DO  40  K=l , J 

p  Al  1 

FOU 

A  **  A 

230 

DA       W  /  T  \ 

BA=Y  ( 1 ) 

PAH 

FOU 

240 

n  n     a  A 

BB=0 . 0 

FOU 

n  r  n 

250 

AC=K 

PAII 

FOU 

260 

A  A       A  A  A  A  A 

AC=AC*AA 

PAII 

FOU 

270 

A  A       A  A       T       A  Al 

DO  30  1=2, N 

PAII 

FOU 

280 

Aft       T  4 

AD=I-1 

PAII 

FOU 

290 

AD=AD*AC 

PAII 

FOU 

AAA 

300 

DA     DA     W  /  T  v  trn^Af  /  A  A  \ 

BA=BA+Y ( I ) *FDC0S (AD ) 

PAI  1 

FOU 

A  1  A 

310 

DD      DD     w  /  T  \  i  r  f\T  T  II  /  Af\\ 

BB=BB+Y (I )*FDSIN (AD) 

PAII 

FOU 

AAA 

320 

n  /  ■/  \     a    Ada  iad 

R (K)=2 . 'BA/AB 

PAII 

FOU 

AAA 

330 

D/i/Av     a    Add  /  a  d 

R(KA)=2 .  BB/AB 

PAII 

FOU 

AAA 

340 

1/  A     1/  A  1 

KA=KA+1 

cm  i 
FUU 

1  C  A 

350 

T  p       /  i        p  n      n    \       ^  A      T  A      f  a 

IF  (L.EQ.l)  GO  TO  50 

PAII 

FOU 

360 

n  /  is  a  \  a 

R (KA)=0 . 

PAII 

FOU 

A  ^  A 

370 

RETURN 

FOU 

380 

END 

FOU 

390 
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SUBROUTINE  FPPT  (Vll  V12,P10,XA) 

FPP 

10 

r 

VERSION  5.0           FPPT  5/15/70. 

FPP 

20 

V1=V11 

FPP 

30 

V2=V12 

FPP 

40 

P0=P10 

FPP 

50 

c 

CALLS  PROB  AND  THEN  USES  ISOLATE  METHOD  FOR 

SOLVING 

ITERATIVELY 

FPP 

60 

DIMENSION  X (5) ,  P (5) 

FPP 

70 

IF  (Vl-1.5)  10,10,20 

FPP 

80 

c 

USE  STUDENT'S  T 

FPP 

90 

c 

ONLY  GOOD  FOR  P0=0.05 

FPP 

100 

10 

CALL  TPCTPT  (V2,XA) 

FPP 

110 

XA=XA**2.0 

FPP 

120 

GO  TO  70 

FPP 

130 

20 

IF  (V2-1.5)  30,30,40 

FPP 

140 

c 

ONLY  GOOD  FOR  P0=0.05 

FPP 

150 

c 

SHOULD  USE  STUDENT'S  T 

FPP 

160 

30 

XA  =  225.0 

FPP 

170 

GO  TO  70 

FPP 

180 

c 

TUKEY  APPROXIMATION  TO  NORMAL  PERCENT 

POINT 

FPP 

190 

40 

YP=-4.91*(P0**.14-(1.-P0)**. 

14) 

FPP 

200 

c 

AMS  55  APPROXIMATION  26.5.22 

FPP 

210 

H=2. 0/(1.0 /(Vl-1.0) +1.0/ (V2- 

1.0)) 

FPP 

220 

XLMBDA=(YP**2-3.0)/6.0 

FPP 

230 

W=YP*FSQRT (H+XLMBDA) /H 

FPP 

240 

IF  (V1-V2)  50,60,50 

FPP 

250 

50 

W=W-(1.0/(V1-1.0)-1.0/(V2-1. 

0))*(XLMBDA+0. 833333- 

-0. 

&66667/H) 

FPP 

260 

c 

AMS  55  APPROXIMATION  26.6.16 

FPP 

270 

60 

XA=FEXP(2.*W) 

FPP 

280 

70 

XMIN=0.5*XA 

FPP 

290 

XMAX=2.0*XA 

FPP 

300 

CALL  PROB  (V1,V2,XMAX,Q) 

FPP 

310 

IF  (Q.LE.PO)  GO  TO  80 

FPP 

320 

XA=1.9999*XMAX 

FPP 

330 

GO  TO  70 

FPP 

340 

80 

CALL  PROB  (V1,V2,XMIN,Q) 

FPP 

350 

IF  (PO.LE.Q)  GO  TO  90 

FPP 

360 

XA=0.5001*XMIN 

FPP 

370 

GO  TO  70 

FPP 

380 

90 

XO=XA 

FPP 

390 

DO  140  1=1,5 

FPP 

400 

X ( I )=XMIN+FLOAT ( I -1 ) * (XMAX-XMI N ) /4 . 

FPP 

410 

100 

CALL  PROB  (V1,V2,X(I) ,P(I)) 

FPP 

420 

110 

IF  (PO-P(I))  140,130,120 

FPP 

430 

120 

XMAX=X ( I ) 

FPP 

440 

XMIN=X(I-1) 

FPP 

450 

GO  TO  150 

FPP 

460 

130 

XA=X(I) 

FPP 

470 

GO  TO  160 

FPP 

480 

140 

CONTINUE 

FPP 

490 

150 

XA=(XMIN+XMAX) /2. 

FPP 

500 

c 

EXIT  IF  EITHER  TOLERANCE  IS 

SATISFIED 

*  ABSOLUTE 

5E 

-6, 

REL.  5E-7 

FPP 

510 

IF  (ABS(XO-XA) .GT.5.E-6.AND.ABS(X0-XA)/XA.GT 

.5.E- 

-7) 

GO 

TO  90 

FPP 

520 

160 

X  V  V 

RETURN 

FPP 

530 

END 

FPP 

540 
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409-118  OL  -  71  -  7 


SUBROUTINE  FPROB 

rno 

FPR 

1  A 

10 

c 

\«rnr  t  Aki        r     aa                  rnDAD                     C  ltd  /  "7  A 

VERSION     5.00          FPROB  5/15/70 

rnn 

FPR 

A  A 

20 

c 

tun  TTTCll     DU         CDCAVIV                                                1  ft  11  1  lil 

WRITTEN  BY     5  PtAVY  10/13/67 

FPR 

*>  A 

30 

c 

COMMAND  IS  AS  FULLUWlNb 

FPR 

A  A 

40 

c 

rfiQAQ  A  D  T  1   T  TV    111    &      \l  O   A         C             £         CTADC     A     TU  rrtl 

FPR0BABILIIY  VI  »  ,VZ  *  ,   r        $  ,   blUKt  (J  IN  LUL  ++ 

FPK 

C  A 

50 

COMMON  /BL0CRC/  NRC  ,RC  (12600) 

FPR 

/  A 

60 

COMMON  /BL0CKD/  IARGS(IOO) , KIND ( 100 ) ,ARGTAB ( 100 ) , NRMAX , NR0W,NC0L ,  NFPR 

T  A 

70 

lAKu O  ,  V  WA  I  L  \  0  )  ,  t»i_r\r\Ur\ 

FPR 

rrR 

O  A 
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NRMAX=KN 

RETURN 

END 
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SUBROUTINE  FREQCY  (X,F,N,K,C,NSTART, START, LIMITS, XL, XU) 
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FUNCTION  FSIN  (X)  FSI  ,10 

C         VERSION    5.00         FSIN             5/15/70  FSI  20 

C  FSI  30 

C         THIS  FUNCTION  IS  TO  TRAP  IF  ARGUMENT  IS  GREATER  THAN  3.3E7  IN         FSI  40 

C         ABSOLUTE  VALUE  BEFORE  SYSTEM  DOES.  RESULT  SET  =0.0                          FSI  50 

C  FSI  60 

COMMON  /CONSLB/  XTRIG,XEXP  FSI  70 

IF  (ABS(X) .GT.XTRIG)  GO  TO  20  FSI  80 

FSIN=SIN(X)  FSI  90 

10        RETURN  FSI  100 

20        CALL  ERROR  (104)  FSI  110 

FSIN=0.  FSI  120 

GO  TO  10  FSI  130 

END  FSI  140 


FUNCTION  FSQRT  (X)  FSQ  10 

C         VERSION    5.00         FSQRT  5/15/70                                                   FSQ  20 

C         FSQRT  CHECKS  X  FOR  NEGATIVE  VALUES.  FSQ  23 

C         IF  X.LT.  ZERO,  RESULT  IS  ZERO,  AND  DIAGNOSTIC  IS  PRINTED.                FSQ  25 

IF  (X.LT.O.)  GO  TO  20  FSQ  30 

FSQRT=SQRT (X)  FSQ  40 

10        RETURN  FSQ  50 

20        CALL  ERROR  (101)  FSQ  60 

FSQRT=0 .  FSQ  70 

GO  TO  10  FSQ  80 

END  FSQ  90 


FUNCTION  FTANH  (X)  FTA  10 

C         VERSION    5.00         FTANH           5/15/70  FTA  20 

C  FTA  30 

C         SINCE    TANH  FUNCTION  USES  EXP  FUNCTION  FTANH  CHECKS  TO  SEE  IF  THEFTA  40 

C         ABSOLUTE  VALUE  OF    2*X    IS  GREATER    THAN  XEXP     (OR    88.3).  IF  THISFTA  50 

C         IS  THE  CASE,  AND  ERROR  MESSAGE  IS  PRINTED  AND  FTANH=0 .  FTA  60 

C  FTA  70 

COMMON  /CONSLB/  XTRIG,XEXP  FTA  80 

IF  (ABS(2.*X) .LE.XEXP)  GO  TO  20  FTA  90 

FTANH=0 .0  FTA  100 

10       RETURN  FTA  110 

20        FTANH=TANH (X)  FTA  120 

GO  TO  10  FTA  130 

END  FTA  140 
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IF (KIND (1 ) .EQ . 1 .AND  .NR  .  EQ  .  1 )  CALL  VECTOR  (RC(IL).IL)  FUN1730 

RETURN  FUN1740 

END  FUN1750 


101 


SUdKUU  1  INt  bcNcK 

GEN 

10 

c 

UCDC  TAM        C     ftft                 P  C  AI  C  D                     C  /  1  C  /  7  ft 

VcKbluN     5.00           btNtK  5/15/70 

GEN 

20 

COMMON  /BLOCRC/  NRC ,RC  (12600) 

GEN 

30 

COMMON  /BLOCKD/  IARGS(IOO) ,KIND(100) , ARGTAB (100 ) , NRMAX ,NR0W, NCOL , NGEN 

A  A 

40 

1ADPC    WIVVV7  rd  \  MITDDnD 

lAKbo  ,  VWaYZ.  (o  )  ,NtKKUK 

PPM 

btN 

C  A 

50 

ft  T  MFMC  T  HRI    AOPC  /  1  Oft  \ 

btN 

60 

rnn  t  u  ai pkipf   /arpqmi  rp  / i 9k ai i i 

tyUlVALLNLL    (AKUJ  (1  )  ,ltt  (liJUl  )  ) 

PFW 

btN 

70 

p 

c 

UC.Lc.lt  DLULIVt 

btN 

O  A 

80 

p 

PFMFRATF 
OlNlKA 1 L 

PFN 
btN 

A  A 

90 

p 

MADrc    MIICT   RP      CP      A    AMD  Fl/FN 
NSKuj    MUj 1    DC    .  Ut  .    «t    AHU    CV CN 

PPM 
UtN 

i  ft  ft 
100 

TP    fMARPC:    CP    A    AMD    UDD f N  ARPC    91    PO    ft\    CO   TO  in 
1  r     (NAROJ  .UL  .  H  .  MIMU  .  NIUU  (HAnuj  ,  £  )  .  Cw.  .  U  ;    uU    1  U  IU 

PPM 

lift 

110 

P  AI  1     CDBflP     M  ft  1 
LALL   tKKUK    (  1 U  ) 

PPM 
btN 

lift 

120 

rn  Tft  oft 
oU    1 U  7U 

PPM 
btN 

1 1  ft 
130 

p 

PPT   CTO.P AP.F   rni  IIMM  AfinPFCC 
Ol  1     O  1  UnAuC    LULUMN    AUUHlj  j 

PPM 
btN 

1  A  ft 

140 

1  ft 

r  AI  1     AflPFQQ    /MAPPQ     1  \ 
CALL    AUnCjj     ( IMMftU  j  (  J  J 

PPM 

Otll 

1  C  ft 

15U 

tp   i  i  pt  n\  pn  th  oft 
I  r    ( J  .  b  I  .  u  )  oU   IU  c.  u 

PPM 
btN 

T  L  ft 

160 

P  AI  1    FRRO.R    r  1  \ 
l/ALL    CI\I\UI\  \J) 

PPM 

17ft 

170 

pn  to  on 

OU     1 U  7U 

PPM 
btn 

1  O  ft 

180 

1  ft 

ZQ 

TP    /KIPRROR   NP   ft\    P(l   TO  Qft 

PPM 

i  A  ft 
190 

p 

mNVFRT   TNTFPFRC  Tfl  Fl  flAT  T  NP  PP.TNT 

PFN 

*>  ft  ft 
200 

nn  %n  t_9  nappc 

PFN 

1 1  ft 
210 

TF    fKTNfWT    1  \    PO  ft\    ARPC  M    11  —  TARPCM  11 

PFN 

1 1  /\ 
220 

i  n 
30 

mNTTNIIF 

PFN 

*5  1  ft 

230 

RP  /  1 \ _ARPC  Ml 

PFN 

2*»0 

KinPOUf—  1  ^MRHUI  1 
NUKU n= J II— 1 

PFN 

O  C  ft 

25U 

fin   7ft    T—  A   NARPC  9 
UU    /U  1=1,I1ARuJ,i 

PFN 

Utll 

1  L  ft 

260 

TF    /  ARPC  /  T    ^1    PT    ARPC/T    1\\    ARC?  l!    9 \ _ C T PM / ARPC  /  T    91  11 
lr    (AKuj  (  1  —  J  )  .  b  1  .Al\b5(l— 1)  )    AKbo  ( 1  —  c)  =5  lbN(AKbo(l—  c  )  ,  — 1  .  ) 

PFN 

*i  i  ft 
2/0 

Q—CTPNM       ARPC  1  T    91  1 
J— J  1 uN ( 1 .  ,  AKb i  (  1  —  i)  ) 

PFN 
utli 

O  O  ft 

2o0 

FMnPR— ARPC/T    11      ft1*ARPCM    9  1 
CNUCl\=Ml\u3  \  1  —  1 ;  —  .  U 1  AI\uj(1  —  C) 

PFN 
ucn 

O  ft  ft 

290 

40 

1—  1  ■  1 

PFN 

3ftft 

RP  1  1  1— RP  M    11  ,  ARr,<  /  T    9  1 
KVs  ( J  ;  =l\U  v  J  —  1 ;  +Mi\«  j  \  1  —  £  ) 

PFN 

Olft 

310 

TF     fC*/RP/!l    FMnPRll    Cft    Aft  Aft 

PPN 

1  O  ft 

320 

p 

mot  nnniF 
nu i  uurac 

CPN 

330 

C  ft 

50 

tf  /i  it  unRnufi  pn  Tn  a<\ 
lr    (j.li  .nuKuwj  ou   iu  *?u 

PFN 

1  A  ft 

340 

p 

FYrppnpn  rni  mum  i fnpth 

CALCCUCU    LULUIWI    LlIIU  1  n 

PPN 

p  A  1  I     FPRO.R     /  O  ft  1  1 

PFN 
ucn 

1  L  ft 

360 

f  n    Tft  Oft 

bU    IU  80 

PFN 

17ft 

3/0 

p 
C 

DACCFC    PFMFDATP    1 IDDPD    Qftl  IMft       CFT    IU    IIDDFR    DPI  IMn 

r Aooco  btNtKA  1  c  UrrtK  DUUNU  ,   be  1    IN  UrrtK  DUUNII 

PPM 
bCN 

i  on 
3o0 

60 

RC(J)=ARGS(I-1) 

GEN 

ion 
3V0 

70 

CONTINUE 

GEN 

Ann 

80 

NRMAX=MAX0 (NRMAX , J-NDR0W+NR0W) 

GEN 

A  1  ft 

410 

90 

RETURN 

GEN 

A  1  ft 

420 

END 

GEN 

430 

102 


SUBROUTINE  GOUAD 

QUA 

10 

r 

VERSION    5.00         GQUAD  5/15/70 

QUA 

20 

r 

WRITTEN  BY  DAVID  HOGBEN  SEL ,  NBS .  8/18/69. 

QUA 

30 

COMMON  /BLOCKD/  IARGS(IOO) ,KIND(100) ,ARGTAB(100) , NRMAX ,NR0W,NC0L ,NQUA 

40 

1ARGS,VWXYZ(8) ,NERR0R 

QUA 

50 

COMMON  /BLOCRC/  NRC  , RC  ( 12600 ) 

QUA 

60 

DIMENSION  ARGS(IOO) 

QUA 

70 

EQUIVALENCE  (ARGS (1) ,RC (12501) ) 

QUA 

80 

c 

DOUBLE  PRECISION  USED  TO  AVOID  NOISE  IN  8TH  DIGIT. 

QUA 

100 

c 

SLIGHT  NOISE  MAY  BE  LEFT  DUE  TO  CONVERSION  FROM  DP  TO  SP 

QUA 

110 

DOUBLE  PRECISION  C ,B , BPA , BMA , DELGQ , STORE 1 ,ST0RE2 

QUA 

120 

c 

TAKEN  FROM  SYMBOLIC  LISTING  PAGE  251  (YELLOW  COVER)  JULY, 1965 

QUA 

130 

c 

A  GOES  TO  C  BECAUSE  A  DIMENSIONED 

QUA 

1 4  0 

10 

IF  (NARGS.EQ.5)  GO  TO  20 

QUA 

150 

CALL  ERROR  (10) 

QUA 

160 

RETURN 

QUA 

17  0 

c 

N  MUST  BE  AN  EXACT  MULTIPLE  OF  4  AND  LESS  THAN  NROW 

QUA 

180 

20 

NGQ=INT (ARGS (1) ) *KIND (1 )+IARGS (1) * (1-KIND (1 ) ) 

QUA 

1€>0 

IF  (M0D(NGQ,4) . EQ . 0 . AND . NGQ .GT . 0 )  GO  TO  50 

QUA 

2  O  0 

30 

CALL  ERROR  (3) 

QUA 

210 

RETURN 

QUA 

2  2 0 

40 

CALL  ERROR  (10) 

QUA 

230 

RETURN 

QUA 

240 

50 

IF  (NGQ. GT. NROW)  GO  TO  30 

QUA 

250 

c 

RESET  NRMAX  IF  NECESSARY 

QUA 

260 

NRMAX=MAXO (NGQ , NRMAX ) 

QUA 

270 

CALL  ADRESS  (4 , JPGQ) 

QUA 

2  8  0 

IF  (JPGQ)  30,40,60 

QUA 

290 

60 

JPGQ=JPGQ-1 

QUA 

300 

CALL  ADRESS  (5,JWGQ) 

QUA 

310 

IF  (JWGQ)  30,40,70 

QUA 

3  2  O 

70 

JWGQ=JWGQ-1 

QUA 

330 

IF  (NERROR.NE.O)  RETURN 

QUA 

340 

C=ARGS(2)*FL0AT(KIND(2) ) +FLOAT ( IARGS (2 ) * (1-KIND (2) ) ) 

QUA 

350 

B=ARGS(3)*FL0AT(KIND(3) ) +FLOAT ( I ARGS (3 ) * (1-KIND (3) ) ) 

QUA 

360 

DELGQ=NGQ 

QUA 

370 

DELGQ=4 .DO* (B-C) /DELGQ 

QUA 

380 

DO  80  1=1, NGQ, 4 

QUA 

390 

B=C+DELGQ 

QUA 

400 

BPA=(B+C) /2 . DO 

QUA 

410 

BMA=(B-C) /2 .DO 

QUA 

420 

K1=I+JPGQ 

QUA 

430 

K2=I+JWGQ 

QUA 

J  4  p 

ST0RE1=-. 86 11363 11594053 DO*BMA 

QUA 

450 

ST0RE2=-. 33998 1043584856D0*BMA 

QUA 

460 

RC (Kl )=FDPCON (ST0RE1+BPA) 

QUA 

470 

RC(K1+1)=FDPC0N(ST0RE2+BPA) 

QUA 

48© 

RC (Kl+2 )=FDPC0N (BPA-ST0RE2 ) 

QUA 

490 

RC (Kl+3 )=FDPCON (BPA-ST0RE1 ) 

QUA 

500 

RC (K2)=FDPC0N ( . 347854845 137454D0*BMA) 

QUA 

510 

RC(K2+1)=FDPC0N( . 652145154862546D0*BMA) 

QUA 

520 

RC(K2+2)=RC(K2+1) 

QUA 

530 

RC(K2+3)=RC(K2) 

QUA 

540 

80 

C=B 

QUA 

5  30 

RETURN 

QUA 

560 

END 

QUA 

570 

103 


c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 


10 
20 

30 

40 
50 
C 

60 

C 
C 
C 
C 
C 

70 


SUBROUTINE  HDIAG  (A ,N , IEGEN ,U , COL , VECTOR ,NROW,H) 
VERSION    5.00         HDIAG  5/15/70 

DIMENSION  A(NR0W,1),  H(54,54),  U(54,54),  X(54),  IQ(54),  COL(l), 
1CT0R(NR0W,1) ,  IEGEN (2 ) 
MIHDI3,  FORTRAN  II  DIAGONALIZATION  OF  A  REAL  SYMMETRIC  MATRIX  BY 

THE  JACOBI  METHOD. 
MAY  19,  1959 

CALLING  SEQUENCE  FOR  DIAGONALIZATION 

CALL    HDIAG (  H,  N ,  IEGEN,  U,  NR) 
WHERE  H  IS  THE  ARRAY  TO  BE  DIAGONALIZED . 
N  IS  THE  ORDER  OF  THE  MATRIX,  H. 

IEGEN  MUST  BE  SET  UNEQUAL  TO  ZERO  IF  ONLY  EIGENVALUES  ARE 
TO  BE  COMPUTED. 

IEGEN  MUST  BE  SET  EQUAL  TO  ZERO  IF  EIGENVALUES  AND  EIGENVECTORS 
ARE  TO  BE  COMPUTED. 

U  IS  THE  UNITARY  MATRIX  USED  FOR  FORMATION  OF  THE  EIGENVECTORS. 

NR  IS  THE  NUMBER  OF  ROTATIONS. 

A  DIMENSION  STATEMENT  MUST  BE  INSERTED  IN  THE  SUBROUTINE. 
DIMENSION  H(N,N),  U(N,N) ,  X(N),  IQ(N) 


THE  SUBROUTINE  OPERATES  ONLY  ON  THE  ELEMENTS  OF  H  THAT  ARE  TO  THE 
RIGHT  OF  THE  MAIN  DIAGONAL.     THUS,  ONLY  A  TRIANGULAR 
SECTION  NEED  BE  STORED  IN  THE  ARRAY  H. 


DO  10  1=1, N 
DO  10  J=l ,N 
H(I,J)=A(I,J) 
CONTINUE 

IF  ( IEGEN (1) )  60,20,60 

DO  50  1=1, N 

DO  50  J=1,N 

IF  (I-J)  40,30,40 

U(I ,J)=1.0 

GO  TO  50 

U(I,J)=0. 

CONTINUE 


NR=0 

IF  (N-l) 


440,440,70 


80 
90 


SCAN  FOR  LARGEST  OFF  DIAGONAL  ELEMENT  IN  EACH  ROW 

X(I)  CONTAINS  LARGEST  ELEMENT  IN  ITH  ROW 

IQ ( I )  HOLDS  SECOND  SUBSCRIPT  DEFINING  POSITION  OF  ELEMENT 

NMI1=N-1 

DO  90  I=1,NMI1 

X(I)=0. 

IPL1=I+1 

DO  90  J=IPL1,N 

IF  (X(I)-ABS(H(I,J)))  80,80,90 
X(I)=ABS(H(I,J)) 

IQ(D=J 
CONTINUE 


HDI 
HDI 
VEHDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 
HDI 


10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
180 
190 
200 
210 
220 
230 
240 
250 
260 
270 
280 
290 
300 
310 
320 
330 
340 
350 
360 
370 
380 
390 
400 
410 
420 
430 
440 
450 
460 
470 
480 
490 
500 
510 
520 
530 
540 
550 
560 
570 
580 
590 
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c 
c 


c 
c 
c 
c 

100 

110 
120 


130 

C 

C 

140 
150 
160 


170 
180 
C 

C 
C 

190 

C 

C 


c 
c 
c 

200 


HDI  600 
HDI  610 
HDI  620 
HDI  630 
HDI  640 
HDI  650 
HDI  660 
HDI  670 
HDI  680 
HDI  690 
HDI  700 
HDI  710 
HDI  720 
HDI  730 
HDI  740 
HDI  750 
HDI  760 
HDI  770 
HDI  780 
HDI  790 
HDI  800 
HDI  810 
HDI  820 
HDI  830 
HDI  840 
HDI  850 
HDI  860 
HDI  870 
HDI  880 
HDI  890 
HDI  900 
HDI  910 

COMPUTE  TANGENT,  SINE  AND  COSINE ,H  (I , I ) ,H  (J  ,  J )  HDI  920 

TANG=SIGN(2.0, (H  (IPIV  ,  IPIV) -H  (JPIV  JPIV) ) )*H (IPIV , JPIV) / (ABS (H (IPIHDI  930 
1V,IPIV)-H(JPIV(JPIV))+FSQRT((H(IPIV,IPIV)-H(JPIV,JPIV) ) **2+4 . 0*H ( IHDI  940 
2PIV,JPIV)**2)) 

C0SINE=1./FSQRT(1.0+TANG**2) 

SINE=TANG*COSINE 

HII=H(IPIV, IPIV) 

H(IPIV,IPIV)=C0SINE**2*(HII+TANG*(2.*H(IPIV,JPIV)+TANG*H(JPIV/JPIVHDI  990 
1)))  HDI 1000 

H( JPIV ,JPIV)=C0SINE**2*(H( JPIV, JPIV) -TANG* (2. *H ( IPIV, JPIV) -TANG*HIHDI1010 


SET  INDICATOR  FOR  SHUT-OFF .RAP=2**-27 ,NR=NO .  OF  ROTATIONS 

HDTEST=1.0E37 

RAP=7 .45058059E-9 

FIND  MAXIMUM  OF  X(I)  S  FOR  PIVOT  ELEMENT  AND 
TEST  FOR  END  OF  PROBLEM 

DO  130  I=1,NMI1 

IF  (1-1)  120,120,110 

IF  (XMAX-X(I))  120,130,130 

XMAX=X(I) 

IPIV=I 

JPIV=IQ(I) 

CONTINUE 

IS  MAX.  X(I)  EQUAL  TO  ZERO,  IF  LESS  THAN  HDTEST,  REVISE  HDTEST 

IF   (XMAX)  440,440,140 

IF  (HDTEST)  160,160,150 

IF  (XMAX-HDTEST)  160,160,190 

HDIMIN=ABS(H(1,1)) 

DO  180  1=2, N 

IF  (HDIMIN-ABS(H(I ,1) ) )  180,180,170 

HDIMIN=ABS(H(1 ,1) ) 

CONTINUE 

HDTEST=HDIMIN*RAP 

RETURN  IF  MAX .H (I , J )LESS  THAN (2**-27 ) ABSF (H (K ,K)-MIN ) 

IF  (HDTEST-XMAX)  190,440,440 

NR=NR+1 


HDI  950 

HDI  960 

HDI  970 

HDI  980 


210 
C 
C 
C 


ID) 

H(IPIV,JPIV)=0. 
PSEUDO  RANK  THE  EIGENVALUES 

ADJUST  SINE  AND  COS  FOR  COMPUTATION  OF  H(IK)  AND  U(IK) 
IF  (H(IPIV,IPIV)-H(JPIV,JPIV))  200,210,210 
HTEMP=H(IPIV,IPIV) 
H(IPIV,IPIV)=H(JPIV,JPIV) 
H(JPIV,JPIV)=HTEMP 

RECOMPUTE  SINE  AND  COS 
HTEMP=SIGN (1.0, -SINE) *COSINE 
COSINE=ABS(SINE) 
SINE=HTEMP 
CONTINUE 

INSPECT  THE  IQS  BETWEEN  1+1  AND  N-l  TO  DETERMINE 
WHETHER  A  NEW  MAXIMUM  VALUE  SHOULD  BE  COMPUTED  SINCE 


HOI  1020 
HDI1030 
HDI1040 
HDI1050 
HDI1060 
HDU070 
HDI1080 
HDU090 
HDI1100 
HDI1110 
HDI 1120 
HDI1130 
HDI1140 
HDI1150 
HDI1160 
HDI1170 
HDU180 
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a 

tuc    DDCCCWT    MAYTMIIM    TC    TM    TUC    T    t\Q     1  DP.11I 

1  Ht  rKtbtra 1    MAAIMUM  lb    in    IHt   1   UK  J  KUW. 

LI  A  T  1  1  A  A 

HU1 1190 

C 

LI  A  T  1  1  A  A 

HU1 1200 

T\f\    OQto    T_l    KIMT  1 

U  A  T  1  1  1  A 

HU 1 12 10 

TC    /  T    I D T M \    lift   ogn  oon 
lr    (1— lrlV)  23U,2oU,22U 

MAT! 1 1 A 

HU 1 1220 

220 

tc    /  t    idtv/\   nn  ion  iin 
lr    (1-Jrlv)    23U  ,  2oU  ,230 

LI  A  T  1  1  1  A 

HU 1 1230 

23U 

TC     /  T  A  /  T  \    TDT\/\    OylA    OCA    O  vl  A 

Ir    (114(1)—  lrlV)   24  U  ,  2DU  ,  24U 

LI  A  T  1  1  A  t\ 

HU 11240 

o  yl  A 
240 

TC     n  A  /  T  \     1  D  T  W  \    O  O  A    OCA  ion 

Ir    (iy(l)— JrlV)  2oU,25U,2ou 

U  A  T  1  1  C  A 

HU 1 1250 

25U 

K    T  P.  /  T  \ 

K=iy (i ) 

U  A  T  1  1  £  A 

HU 1 1260 

UTCMD    U If    V \ 
n  1  LIVIr=n  ( 1  ,  a.  ) 

U  A  T  1  1  7  A 

HU1 1270 

U  /  T    V  \  to 
n  ( l  ,  r\ )  =u  . 

HU 1 12o0 

T  DI  1  Til 

lrLl=l+l 

LI  A  T  1  1  A  A 

HU 1 1290 

Y  /  T  \  A 

X (1 )=0 . 

LI  A  T  1  1  A  A 

HU1 1300 

L 

U  A  T  1  1  1  A 

HU1 1310 

r 
ii 

CCADPU    TM    nCDI  CTCn    DAill   COD    MCUf  MAYTMIIM 

ItAKln  Ira  UtrLt  I  lu  KUW  r  UK  nc.fl  MAaIMUM 

u  n  T  1  1 1  A 

HU1 1320 

U  A  T  1  11  to 

HU1 1330 

nn   nn    1    TDIl  M 
UU   2  /  U  J  =  l  rLl  ,  IM 

U  A  T  1  1  A  to 

HU1 1340 

TC     (V  (  I  \     ADC  ;LJ  /  I                    1/,n    1i  n  17(1 
IT     ( A ( 1 ) — ADO (H ( 1 , J ) ) )  26U,26U,2/U 

un  t i i cn 
HU1 13DU 

20U 

Y  11  \     ARC  /  U / T     1  \  \ 
A ( 1 )=ADb (n ( 1 , J ) ) 

un  T 1  1 L to 
HU 1 1360 

1 U.  ( 1 )  =  J 

LI  A  T  1  51A 

HU1 1370 

7  7  ft 

PO.MT  ?  Ml  IIP 
\»ura  i  i  rauc 

LI  A  T  i  ion 
HU 1 13oU 

U  1  T    V \  UTCMD 

n  ( 1  ,r\ )=H  I  tMr 

LI  A  T  1  1  Q  to 

HU 1 1390 

9  a  n 
&  o  y 

POMT  T  Ml  IC 

UUN 1 1 rout 

LI  A  T  1  A  A  A 

HU 1 1400 

p 

u  n  T  1  A  1  A 
HU 1 14 1U 

Y / TDTU\_n 
A ( 1 r 1 V ) =U . 

un T t  ao to 
HU 1 142U 

y i  ipivi —to 
A ( J  r 1 V ) =U . 

un  T 1  A  1  to 
nUl 143U 

p 

U  A  T  1  A  A  to 

HU1 1440 

r> 
t 

PUAMPC    TUC    P.TUCD    CI  CMCMTC    P.C  U 

UHArabt   Int  U  IHtK  tLtMtn 1 b  Ur  H 

U  A  T  1  A  C  A 

HU1 1450 

p 

Un  T  1  A  L.  to 

HU 1 1460 

r\A    lift    t    i  kj 

UU  410  1=1 ,  n 

Un  T 1  Alto 

HU 1 1470 

p 

U  A  T  i  a  O  A 

HU 1 14oU 

TC     /T     TDT\/\     OQA    Alto    11  to 

Ir    (1-lrlv)  290,410,33U 

un  T  1  A Q A 

HU 1 149U 

■I  a  n 

UTCMD— U/T  TDTW\ 

tl  1  tMr=n  ( 1  , 1  r  1 V  ) 

un i i cnn 
HU 1 15UU 

U/T     T  D  T  W  \    PP.C  T  MC  *UTCMD  ■  C  T  MC  *U  /  T     1  D  T  M  \ 

n  ( 1  , 1  r  1 V  )  =viUj  1  rat  HltMr+oirit  n(l,Jrlv) 

umi  ci  n 

4                 HU 1  ID 1U 

TC    /Y/T\    ARC/UM    TDTUV\\    Itoto    11  to  ]in 
ir    I A ( 1 ) — AD J ( H ( 1  ,  1 r 1 V  )  )  )  3UU,31U,31U 

un t  t  con 

inn 
3UU 

Y/T\     ARC/U/T     IDTUl \ 
A ( 1 ) =ADJ (H(l  ,  1  r  1  V  )  ) 

un  t i cin 

HU 1 153U 

T  n.  /  T  \  IDIV 
lU.  (  1  )  =  lrl  V 

un  t i can 

J  J  u 

U/T     IDTl/V       C  T  MC*UTCMD  ■  PP.C  T  MC  *U  11     1 D  I U  \ 

H ( 1 , J r 1 V ) =— b 1 rat  HltMr+LUblrat  n(l,JrlV) 

un  t i c  cn 
nu 1 1 D  DU 

TC    /Y/T\    ARC/U/T     1 D  T 1/ \  \  \    ion    Alto  Alto 

Ir   (A  (1 )— AD5  (n  (1  ,  Jri  V ) )  J  «l),liu,'tiu 

unT i sin 
nu i 130U 

lift 

320 

V/T\     ARC/U/T  IDT\/\\ 

A ( 1 )=Abb (H  ( 1 ,  J  r  1 V ) ) 

uni i C7n 
HU 1 15 / U 

f A / f \  IDTW 

Hi  ( 1 )=Jr 1 V 

un  t i c  fin 
HU 1 15oU 

P  n    Trt    A  1  A 

bU    IU  410 

un  t i con 
HU 1 159U 

p 

un  t  t  Ann 
HU 1 lOUU 

1  1  A 
33U 

TC     it     IDT\/\    1 A  to    illA    n  to 

Ir    (1-JrlV)  340,410,3/0 

un  Tiiin 
HU 1 10 1U 

lAto 
34U 

UTCMD    U/TDTW  T\ 

H 1 1  Mr =n ( 1 r 1 V , 1 ) 

un  TiAin 
HU 1 10 tu 

U/TDTU    T\    PAC  T  MC  +  UTCMD  i  C  T  WC*U  M  !DT\/^ 

n ( 1 r 1 V , 1 ) =LUj 1 Nt  nltMr+Dlrat  n(l,JrlV) 

unr i A3rt 

TC     fVMDTUl    ARC  (U/TDTV    T\\\    ten    1.k{\  %kfi 

ir   (A(lrlV)  —AD  j  (n(lriv,i)))  >j\>,  >o\j  ,  jou 

Un  T 1  AAA 
nu i lotu 

left 

350 

V/TDTU\     ADC /U/TDTU    \ \\ 

A ( 1 r 1 V ) =Abj (H(lrlV,l) ) 

unT i a  cn 
nu i lo ju 

Tft/TDTX/\  T 

1U.  ( lrlv)=l 

unT i a An 
nu i ioou 

360 

U/T      |  n  T  w  \       c  T  U  C  *  UTC  MD  ■  Pf\C  T  MC  *  U  /  T  IDTW) 

H  ( 1  ,  JrlV)=-blNt  H  ItMr+LUMNt  n  (1  ,  Jrlv) 

un  t i A7n 
nu  i l o / u 

TC      /  V  /  f  \     ADC/U/T      1 D  T  1/  \  V  \     lift     Alto  VITA 

IF   (X (I )-AB5 (H (I , JPIV) ) )  320,410,410 

un  t i a  a  n 
nu i ioou 

p 

Un  T 1  AO A 

nu i 10 7U 

1  7  A 

370 

UTCMD    U/TDTW  T\ 

H 1 tMr=H ( Ir 1 V , I ) 

un i i 7nn 
nu i i / uu 

U/Tniii    T\     PrtC  T  MC  tUTCUD  .  C  T  MC  *U  /  IDTU  1\ 

H ( I r 1 V , 1 ) =LUb INt  HI tMr +3 Irat  n ( Jr 1 V  ,  1 J 

HOT  1 71 n 
nu 11/ xu 

TC     /V /IDTW)     ADC /U/TDTU    I ) \ )     IQto    XQft  IQto 

lr    (A ( 1 r 1 V ) -Abo  (n ( Ir 1 V , 1 ) ) )  3oU,37U,37U 

un  t l 79 a 
nu i i / c u 

Oftft 

380 

v /IDTW)     ADC /U/TDTW  T\\ 

A ( 1 r 1 V ) =Ado ( M ( I r 1 V , 1 ) ) 

null/ j u 

in / TDTW)  T 

1IJ  ( Ir  1 V  )=»! 

HDT 1 74ft 
n  u  1 1  /  *t  v 

O  A  A 

390 

Ill  IDTW    T\       C  T  MC  *UTCMD  .  PAC  T  MC  *U  1  IDTU    I  1 

H ( J r 1 V , I ) =-b Irat  n 1 tMr+LUb 1 Nt  n(Jrlv,l) 

HOT  1750 

TC    /  y  /  1  D  T  W  \    ARC/UMPTV    1  \  \  \    d.(\fi    AT  0  410 
lr    ( A  ( J r  l  V  )  — ADb  (ri  ( J r  I  v  ,  i )  ) )   huu  , hiu  ,  tin 

HDI1760 

400 

X(JPIV)=ABS(H(JPIV,I)) 

HDI1770 

106 


IQ(JPIV)=I  HDI1780 

410      CONTINUE  HDI1790 

C  HDI1800 

C         TEST  FOR  COMPUTATION  OF  EIGENVECTORS  HDI1810 

C  HDU820 

IF  (IEGEN(l))  100,420,100  HDI1830 

420      DO  430  1=1, N  HDI1840 

HTEMP=U(I ,IPIV)  HDI1850 

U(I ,IPIV)=COSINE*HTEMP+SINE*U(I , JPIV)  HDI1860 

430      U (I , JPIV)=-SINE*HTEMP+COSINE*U (I , JPIV)  HDI1870 

GO  TO  100  HDI1880 

440      IF   (IEGEN(2)-2)  450,470,450  HDI1890 

450      DO  460  1=1, N  HDI1900 

COL(I)=H(I ,1)  HDI1910 

460      CONTINUE  HDI1920 

IF  (IEGEN(2)  .NE.3)  GO  TO  490  HDI1930 

470      DO  480  J=1,N  HDI1940 

DO  480  1=1, N  HDU950 

VECTOR(I,J)=U(I,J)  HDI1960 

480      CONTINUE  HDI1970 

490      RETURN  HDI1980 

END  HDI1990 
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c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
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20 


30 
40 

50 

60 


70 
80 


SUBROUTINE  HEADS  (LOC  ,N00 , IN , 10) 
VERSION    5.00         HEADS  5/15/70 
REWRITEN  BY  S  PEAVY  8/8/69 

THIS  SUBROUTINE  INSERTS  HEADINGS  (IF  AVAILABE)  OVER  THE  COLUMNS 
WHEN  NO  FORMAT  IS  SPECIFIED 

LOC    LOCATION  WHERE  COL  NUMBERS  ARE 

NOO    NO  OF  COLUMN  HEADINGS  TO  LOOK  FOR.  NOO  LESS  THAN  OR  =  8 . 
IN      IF  IN  =0  NEW  HEADINGS 

IF  IN  =1  PRINT  OUT  HEADINGS  FROM  RREVIOUS  PAGE 

IF  A  HEADING  EXISTS  THE  12  CHARACTER    HEADING  WILL  BE  PRINTED. 
OTHERWISE  THE  HEADING  COLUMN  XXXX  IS  TO  BE  USED  WHERE  XXXX  IS  THE 
NUMBER  CONVERTED  FOR  DECIMAL  PRINTOUT.  THE  HEADINGS  ARE  PRINTED 
OVER  THE  DATA  WHICH  IS  IF  FORMAT  1PBE15.6 

10    =0    PRINT  HEADINGS 

10    NOT  =0    DO  NOT  PRINT  HEADINGS 

COMMON  /ABCDEF/  L(48) 

COMMON  /HEADER/  NOCARD (80 ) , ITLE (60,6)  ,LNCNT , IPRINT ,NPAGE , I PUNCH 
COMMON  /FMAT /  IFMTX (6 ) , IOSWT , IFMTS (6 ) , LHEAD (96 ) 
DIMENSION  LOC(l) 
DIMENSION  IC0LHD(7) 

DATA  ICOLHD(l) ,IC0LHD(2) ,IC0LHD(3) ,IC0LHD(4) ,IC0LHD(5) ,IC0LHD(6) , 
1C0LHD (7 ) / 1HC , 1H0 , 1HL , 1HU , 1HM, 1HN , 1H  / 
NO=NOO 

IF  (N0.GT.8)  N0=8 

IF  (IN.NE.O)  GO  TO  80 

IR=1 

DO  70  1=1, NO 

CALL  PREPAK  (5  ,  IND , I , LOC ( I ) , LHEAD ( IR ) ) 

IF  (IND.NE.O)  GO  TO  10 

IR=IR+12 

GO  TO  70 

DO  20  IS=1,7 

LHEAD(IR)=ICOLHD(IS) 

IR=IR+1 

K=LOC(I) 

KC=1000 

KD=0 

DO  60  IS=1,4 
KA=K/KC 

IF  (KA.NE.O)  GO  TO  30 

IF  (KD.NE.O)  GO  TO  40 

LHEAD(IR)=L(45) 

GO  TO  50 

KD=1 

KAP=KA+1 

LHEAD ( IR)=L (KAP) 

IR=IR+1 

K=K-KA*KC 

KC=KC/10 

LHEAD(IR)=L(45) 

IR=IR+1 

CONTINUE 

IF  (IO.NE.O)  RETURN 
IS=N0*12 


HEA 
HEA 
HEA 
HEA 
HEA 
HEA 
HEA 
HEA 
HEA 


10 
20 
30 
40 
50 
60 
70 
80 
90 


HEA  100 

HEA  110 

HEA  120 

HEA  130 

HEA  140 

HEA  150 

HEA  160 

HEA  170 

HEA  180 

HEA  190 

HEA  200 

HEA  210 

HEA  220 

HEA  230 

HEA  240 

HEA  250 

IHEA  260 

HEA  270 

HEA  280 

HEA  290 

HEA  300 

HEA  310 

HEA  320 

HEA  330 

HEA  340 

HEA  350 

HEA  360 

HEA  370 

HEA  380 

HEA  390 

HEA  400 

HEA  410 

HEA  420 

HEA  430 

HEA  440 

HEA  450 

HEA  460 

HEA  470 

HEA  480 

HEA  490 

HEA  500 

HEA  510 

HEA  520 

HEA  530 

HEA  540 

HEA  550 

HEA  560 

HEA  570 

HEA  580 

HEA  590 
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WRITE  (IPRINT,90)   (LHEAD ( I ) , 1=1 , I S )  HEA  600 

RETURN  HEA  610 

c  HEA  620 

90        FORMAT  (8(3X,12A1))  HEA  630 

END  HEA  640 


409-118  OL  -  71  -  8 
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SUBROUTINE  HISTGM 

HIS 

10 

c 

VERSION    5.00         HISTGM  5/15/70 

HIS 

20 

c 

WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS .  10/24/69. 

HIS 

30 

C0MM0N/ABCDEF/L(48) 

HIS 

40 

COMMON/BLOCRC/NRC,RC( 12600) 

HIS 

50 

COMMON/BLOCKD /     IARGS(IOO) ,KIND(100) , ARGTAB ( 100 ) , NRMAX , 

HIS 

60 

1  NR0W,NCQL,NARGS,VWXYZ(8) ,NERROR 

HIS 

70 

DIMENSION  ARGS(IOO) 

HIS 

80 

EQUIVALENCE (  ARGS(l),  RC(12501)) 

HIS 

90 

COMMON/BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG 

HIS 

100 

COMMON/HEADER/NOCARD (80 ) , ITLE (60,6) , LNCNT , IPRINT ,NPAGE , IPUNCH 

HIS 

110 

C0MM0N/SCRAT/NS,NS2,A(13500) 

HIS 

120 

c 

HISTOGRAM  FOR  MIDPOINTS  IN  COLUMN  (C) ,  FREQUENCIES  IN  COLUMN 

(C) 

HIS 

130 

c 

NHISTOGRAM  (C) ,   (C)     L2=2  DOES  NOT  CALL  NEW  PAGE  OR  PRINT  BLANK 

HIS 

140 

c 

LINE  BETWEEN  CELLS  OR  HEADING. 

HIS 

150 

L2=L2-7 

HIS 

160 

10 

IF  (NARGS.EQ.2)  GO  TO  20 

HIS 

170 

CALL  ERROR  (10) 

HIS 

180 

RETURN 

HIS 

190 

20 

CALL  ADRESS  (1,J1) 

HIS 

200 

IF  (Jl)  30,40,50 

HIS 

210 

30 

CALL  ERROR  (3) 

HIS 

220 

RETURN 

HIS 

230 

40 

CALL  ERROR  (11) 

HIS 

240 

RETURN 

HIS 

250 

50 

CALL  ADRESS  (2,J2) 

HIS 

260 

IF  (J2)  30,40,60 

HIS 

270 

60 

IF  (NRMAX. GT.O)  GO  TO  70 

HIS 

280 

CALL  ERROR  (9) 

HIS 

290 

RETURN 

HIS 

300 

70 

IF  (NERROR.NE.O)  RETURN 

HIS 

310 

80 

FORMAT  (//  25X,35HHIST0GRAM  FOR  FREQUENCIES  IN  COLUMN , 15 , 22H , 

MID 

-HIS 

320 

1P0INTS  IN  COLUMN, I5//3X,10HMID-P0INTS,7X,9HFREQUENCY/) 

HIS 

330 

85 

FORMAT  (1X,14A1,2X,I5,3X,  95A1) 

HIS 

340 

90 

FORMAT  (25X,  95A1) 

HIS 

350 

100 

CALL  RFORMT  (RC(J1) , NRMAX , 8 , NW1 , NDECl , 13 , A ( 1 ) ,A(1) ,0,0) 

HIS 

360 

NBLANK  =  15-NW1 

HIS 

370 

IF  (L2.EQ.2)  GO  TO  110 

HIS 

380 

CALL  PAGE  (4) 

HIS 

390 

WRITE  (IPRINT, 80)  IARGS (1) , IARGS (2 ) 

HIS 

400 

110 

L0C1=J1 

HIS 

410 

L0C2=J2 

HIS 

420 

DO  200  1=1, NRMAX 

HIS 

430 

CALL  RFORMT  (A (1 ) , 1 , 8 ,NW1 , NDECl , 0 , RC (LOCI ) , A (1 ) , NBLANK , 1 ) 

HIS 

440 

LFREQ  =  RC(L0C2)  +  0.001 

HIS 

450 

IF  (LFREQ. GT.O)  GO  TO  140 

HIS 

460 

WRITE  (IPRINT, 85)   (A ( 1 1 ) , 1 1=2 , 15 ) , LFREQ 

HIS 

470 

GO  TO  150 

HIS 

480 

140 

I2END  =  MINO  (LFREQ, 95) 

HIS 

490 

WRITE  (IPRINT, 85)   (A ( I 1 ) , I 1=2 , 15 ) , LFREQ , (L (40 ) , 12=1 , I2END) 

HIS 

500 

IF  (LFREQ. LE. 95)  GO  TO  150 

HIS 

510 

I3END  =  LFREQ-95 

HIS 

520 

WRITE  (IPRINT, 90)   (L(40)  ,13=1, BEND) 

HIS 

530 

150 

LOCI  =  L0C1+1 

HIS 

540 

200 

L0C2  =  L0C2+1 

HIS 

550 

RETURN 

HIS 

560 

END 

HIS 

570 

110 


c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
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SUBROUTINE  IFS 

VERSION    5.00  IFS  5/15/70 

COMMON  /BLOCRC/  NRC ,RC  (12600) 

COMMON  /BLOCKD/  IARGS(IOO) ,KIND(100) ,AR6TAB(100) ,NRMAX ,NROW,NCOL , 
1ARGS(VWXYZ(8) ,NERROR 
DIMENSION  ARGS(IOO) 
EQUIVALENCE  (ARGS ( 1 ), RC  ( 12501 ) ) 
COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG 
COMMON  /BLOCKX/  INDEX (6 , 8 ), LEVEL 
DIMENSION  II (3) ,K(3) ,NNN(7) 

EQUIVALENCE  (11,11(1)),   (12,11(2)),  (13,11(3)) 
LOGICAL  TWOARG 

THIS  COMMAND  MAY  APPEAR  ONLY  AS  A  STORED  COMMAND. 


IFLT,  IFEQ,  IFGT,  IFGE,  IFNE,  IFLE  CORRESPOND  TO  L2  =  9,  14 
COMPARE        L2  =  15 

COMMANDS  MAY  HAVE  2  OR  3  ARGUMENTS  (ONLY  IFEQ  AND  IFNE  MAY  HAVE  3 
ANY  ARGUMENT  MAY  BE  OF  ANY  TYPE,  COLUMN  NUMBER  OR  CONSTANT. 
COMPARE    MUST  HAVE    3  ARGUMENTS 

IN  COMPARE  THE  TEST  IF  FOR  RELATIVE  ERROR  AND  GOES 


I    ARG1-ARG2     I  I 

I    I   .LT.  I 

I        ARG2  I  I 


ARG3 


IF  ARG2  OR  ARG1  IS  0.,  THEN  ABSOLUTE  ERROR  WILL  BE  COMPUTED 
ABS (ARG2-ARG1 )   .LT.  ARG3  AND  INFORMATIVE  DIAGNOSTIC 
WILL  BE  PRINTED. 

IF  IFEQ  AND  IFNE  CONTAIN  A  THRID  ARGUMENT  (TOLERANCE)  ABSOLUTE 
ERROR  WILL  BE  COMPUTED 

ABS (ARG1-ARG2 )   .LT.  ABS  (ARG3) 
A  GIVEN  TOLERANCE  IS  IGNORED  ON  IFLT,  IFLE,  IFGT,  IFGE 
EXAMPLES  OF  HOW  COMMANDS  READ. 

IFLT    8.32  LT  EVERY  ENTRY  OF  COL  34,  CONDITION  IS  TRUE 

IFGE  EACH  ELEM  COL  1  .GE.  CORRESP.  ELEM.  COL  5,  COND.  IS  TRUE 

IFEQ  2.   .EQ.  5.  CONDITION  TRUE  (USEFUL  WHEN  INCREMENTING  ARGS.  ) 

IF  CONDITION  IS  FALSE,  NO  ACTION  IS  TAKEN. 

IF  CONDITION  IS  TRUE,  THERE  ARE  TWO  POSSIBILITIES.. 

1.  IF  THE  TEST  COMMAND  IS  THE  LAST  ONE  IN  THE  REPEAT  LOOP 
CURRENTLY  BEING  EXECUTED,  THE  LOOP  IS  TERMINATED  (DROPPED 
BACK  TO  THE  NEXT  OUTER  LEVEL  IF  MORE  THAN  ONE  LEVEL  DEEP). 

2.  IF  THE  TEST  COMMAND  IS  NOT  THE  LAST  ONE,  ALL  THAT  HAPPENS  IS 
THAT  THE  REST  OF  THE  LOOP  IS  NOT  PERFORMED.    THAT  IS,  IF  THE 
LOOP  COUNTER  HAS  NOT  REACHED  ITS  UPPER    LIMIT,  IT  IS  ADVANCED 
ONE  AND  THE  LOOP  IS  BEGUN  FROM  THE  TOP  AGAIN. 

IF  (LEVEL. GT.O)  GO  TO  10 
CALL  ERROR  (21) 
GO  TO  120 

IF(NARGS.EQ.2)  IF(L2-15)  40,150,40 
IF  (NARGS.EQ.3)  GO  TO  30 
CALL  ERROR  (10) 
GO  TO  120 


IFS 
IFS 
IFS 

NIFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 

)  IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 
IFS 


10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
175 
180 
190 
200 
205 
210 
220 
230 
240 
250 
260 
270 
272 
273 
278 
280 
282 
284 
286 
290 
300 
310 
320 
330 
340 
350 
360 
370 
380 
390 
400 
410 
420 
430 
440 
450 
460 
470 
480 
490 
500 
510 
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A  A 

20 

ft  A  1  1      CDDftD     /  1  1  \ 

LALL  EKKUK  (11) 

TPP 

IF  5 

C  *i  A 

520 

Tft    i  o A 
bU    IU  LIU 

rrc 

Irb 

530 

1  A 

30 

tc/io  rn  in  no  io  en  1 1  no  io  en  ic\   rn  Tn  /in 
1  r  (  Lt  .  ty  .  11)  .  UK  .  L<:  .  ty  .  I  3  .  UK  .  Li.  .  t(J  .  1  5  )    bU    IU  4U 

irr 

Irb 

540 

ftAI  1     CDDAD     1  1 1  0  \ 
CALL   tKKUK    ( <£  1  Z  ) 

Irb 

CCA 

550 

M  A  D  r  C  O 

NAKbb=2 

t  rrc 
I  r  b 

560 

A  A 

40 

nn  aa  t   i   u Aorc 
UU  60   1=1 , NAKbb 

TPP 

I  r  b 

C  ?  A 

570 

ft  A  1  1      AnDCCC     It  TT/T\\ 
LALL   AUKtbb  (1,11(1)) 

I  PC 

Irb 

C  O  A 

580 

T  C     /  T  T  /  T  \  \     c  A    *y  A  en 

Ir    (11(1))    5U , ZU , OU 

ire 

Irb 

C  A  A 
370 

c  n 
3U 
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1 1 ( 1 )=-l 1 ( 1 ) 
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Irb 

000 

An 
ou 
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76O 

DrTIIDU 

RETURN 

T  CC 

irb 

07n 
7  /  U 

END 

IFS 

980 
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SUBROUTINE  INFERR  (I )  INF  10 

C         VERSION    5.00          INFERR         5/15/70  INF  20 

C         INFORMATIVE  DIAGNOSTICS  200  AND  UP  INF  30 

COMMON /BLOCKC /KIO , INUNIT , ISCRAT ,KBDOUT ,KRDKNT , LLIST  INF  40 

C0MM0N/C0NLB2/ER,ISIGD  INF  45 

ISCRUN=ISCRAT  INF  50 

WRITE(ISCRUN,500)  INF  60 

500      FORMAT ( /41H*  INFORMATIVE  DIAGNOSTIC  IN  ABOVE  COMMAND, 43X)  INF  70 

11=1-200  INF  80 

GO  TO  (401,  402,  403,  404,  405,  406,  407,  408,  409,  410,  411,  412, INF  90 

1  413,414,415,416,417,418,419,420,  INF  100 

2  421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,  INF  105 

3  436,437) ,11  INF  110 

401  WRITE(ISCRUN,201)  INF  120 

201  FORMAT (52H*  TOO  MUCH  DATA  IN  SET,  READ  OR  GENERATE,  SPILL  LOST,      INF  130 
132X)  INF  140 

GO  TO  900  INF  150 

402  WRITE(ISCRUN,202)  INF  160 

202  FORMAT (61H*  COMMAND  NOT  ALLOWED  IN  REPEAT  MODE.  EXECUTED  BUT  NOT  SINF  170 
1T0RED,23X)  INF  180 

GO  TO  900  INF  190 

403  WRITE(  ISCRUN,  203  )  INF  200 

203  FORMAT (61H*  VALUE  REQUESTED  IN  SHORTEN,  ACOALESCE  OR  AAVERAGE  NOT  INF  210 
1F0UND,23X)  INF  220 

GO  TO  900  INF  230 

404  WRITE(  ISCRUN,  204  )  INF  240 

204  FORMAT (32H*  BAD  HEAD.  COLUMN  GT  50  OR  NO  /,52X)  INF  250 
GO  TO  900  INF  260 

405  WRITE(  ISCRUN,  205  )  INF  270 

205  FORMAT (68H*  THIS  COMMAND  WAS  NOT  EXECUTED  BECAUSE  ITS  MEANING  WAS  INF  280 
1QUESTI0NABLE , 16X)  INF  290 

GO  TO  900  INF  300 

406  WRITE(ISCRUN,206)  INF  310 

206  FORMAT  (24H*  F  LESS  THAN  0,  SET  =  0,60X)  INF  320 
GO  TO  900  INF  330 

407  WRITE(ISCRUN,207)  INF  340 

207  FORMAT (24H*  NU1  OR  NU2  LESS  THAN  1,60X)  INF  350 
GO  TO  900  INF  360 

408  WRITE(ISCRUN,208)  INF  370 

208  FORMAT (33H*  NU1  OR  NU2  TRUNCATED  TO  INTEGER, 51X)  INF  380 
GO  TO  900  INF  390 

409  WRITE(ISCRUN,209)  INF  400 

209  FORMAT (34H*  IMPROPER  TITLE  NUMBER,  ASSUMED  1,50X)  INF  410 
GO  TO  900  INF  420 

410  WRITE(ISCRUN,210)  INF  430 

210  FORMAT (54H*  NO  OF  ROWS  NOT  =  TO  COLS.  MATRIX  USED  LARGEST  SQUARE,  INF  440 
1  20X)  INF  450 

GO  TO  900  INF  460 

411  WRITE(ISCRUN,211)  INF  470 

211  FORMAT (52H*  ASTERISK  STRING  IMPLYING  /THRU/  INCORRECT,  IGNORED,      INF  480 
1  32X)  INF  490 

GO  TO  900  INF  500 

412  WRITE(ISCRUN,212)  INF  510 

212  FORMAT (43H*  UNNECESSAYY  ARGUMENTS  IN  COMMAND  IGNORED . ,41X)  INF  520 
GO  TO  900  INF  530 

413  WRITE(ISCRUN,213)  INF  540 

213  FORMAT (27H*  PARTIAL  STORAGE  OF  MATRIX, 57X)  INF  550 
GO  TO  900  INF  560 

414  WRITE  (ISCRUN, 214)  INF  570 
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O  1  A 

Z14 

CftDMAT  /  9  QU*  *  *  T  WCIIFF  T  P  T  CUT    CPDATfU    A  DC  A  ciVl 

rUKMAI  (2on       inoUrrlulc.ni    iLKAILH  AKcA  ,56a) 

Tlir  con 

INr  580 

ro  to  onn 
uU    1 U  7UU 

INr  585 

A  1  C 

415 

WRITE  (ISCRUN,215) 

INF  590 

I  15 

FORMAT  (48H*  NRMAX  IS  NOT  LARGE  ENOUGH  TO  ALLOW  ITERATION      ,36X)  INF  600 

po  to  onn 

bU     IU  7UU 

T  MF  tlfl 

INr  olU 

4  lo 

U/RTTF    /T^PRIIN   9  1  A\ 
hr  lie    i  i  jv«nun  ( tiD  ) 

T  mf  ton 
INr  02U 

9 1  A 
£  10 

FORMAT / ASH*    1  <^T   POI  IIMN   (IF    T^FTIIP   OR    T<OI  ATF          NOT   MONOTONTP  OR 
rUrvMMI  (  Oon       1 J  1     l/ULUMn    ur     lOClUr    Ut\    1  jULK  1  L    1  j    NU  1     MUNUIUIilU  Urv 

T^TNF 

1    PON^TANT            1  AY  \ 

1    LUIIj  1  WW  1  .           ,  IDA  ) 

TNF  LAf\ 

inr  oiu 

po  to  onn 

UU     1 U  7UU 

TWF  iKn 
INr  03U 

A  1  7 
11/ 

U/RTTF    /T^PRIIN  9^7^ 

TNF  tin 
INr  OOU 

21/ 

FORMAT    MAM*    TTFRATTON   MA^   FOUNT!   NO   UAI  1  IF ^  cny\ 
r  Ul\  MM  1      (Jin       1  1  CRM  1  1  UN    nft  j    r  UUPl  U    HU    V  ML  U  C  j  .           ,  DUA  ) 

TWF  t7fl 

INr  o / U 

bU    l  u  7l)U 

Tur  con 
INr  ooU 

A 1  Q 
110 

U/RTTF     /TCPRIIW  91Q\ 
Wl\  1  1  C     (  1  jL-KUIM  ,  i.  1  0  .1 

T mc  can 
INr  07U 

910 

FORMAT /Q1I4*    UIORIfCUFFT    TC    TOO    CUnQT    TO    APPOMMOnATF    Al  1     TUF    \/AI  IICC 
rUKNIfl  1  (Bin      nUKNjntl:  1    1  o    1  UU   inUK  1     IU  AuUUIVIMUUA  1  t  ALL    Inc.  VALUto 

r  t  m  c  7  n  ft 
olNr  /UU 

IFNFRATFn    RV    THTQ    POMMAWn         1Y  \ 
ICIiCKMICU    DT     1  n  1  j          MMM  N  V  .     ,  J  A  ) 

TWF    7  1ft 

iNr  / iu 

UU     IU  7UU 

T  W  C    7  9ft 

INr   / 2U 
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U/RTTF  1  TCPQIIN  91Q\ 
HR  1  IC(,lj^t\Uri,£i7; 

T  MC    7  1ft 

INr   1  i\i 

£  17 

FORMAT    /IflH*    MAYMTW   UAC    COIIWn   MPl   FYTRFMA           cay  \ 
rurcmMi    pun     mm  ami  n  riMj  ruunu  nu  laikcmm.  ,3haj 

TWF    7  Aft 
INr    / 4U 

PO  TPi  onn 
uu    i u  7UU 

T  WF    7  Cft 
INr    / 5U 

A9fl 

WRTTF    /T^PRIIN  77(\\ 

TWF  7Aft 

i rar   / ou 

99n 

FORMAT    /P.4H*    MAXMTN   HA^   FOUNT)   ANT)    TPNORFF1   A   TRTAn   OF   V.^   UITTH  AT 
runniMi    (oin     mm ami n  riMj  ruunu  mwu   lununcu  m   i  rv i mu  ur  a/o  hi  i  n  mi 

1  T  WF  77ft 

Linr  / / u 

IFA^T  TWO   TnFNTTPAl    VAI  1 1 P Q  \ 

ILMj  1      1  ITU    1ULI1  1  1UHL    VHLUlj  .  ) 

TWF  70ft 

i nr   / ou 

GO  TO  Qflfl 

UU     1 U  7UU 

TNF  7Qft 

i nr   / 7U 

A9  1 
Hcl 

WRTTF    /  T^PRIIN  991  * 

TNF  Qftft 

irar  ouu 

991 

FORMATION*   MORF  THAN  ONF   ARPIIMFNT    T  M  POMMANfl     ONI  Y  FTR^T  ONF  T^ 

rUnWIM  1  lJ7M       MUnL     1  nMPI    UriC    MrxVaUMCHI  1     in    UUMMMrvU  .    UIMLY    r  ll\j  1     UntL    1  j 

IITNF  Olft 

u i nr  o iu 

TWF  09ft 
INr  02U 

GO  TO  onn 

UU     1 U  7UU 

TWF    Q  3  ft 

iNr  oju 

A99 

U/RTTF    M^PRIIN  999\ 
nl\  1IC    (  1  jLHUH  ,  t  til  ] 

TWF  OAft 

inr  ohu 

9  9  9 

FORMAT    1  d%U*    FORMAT   NOT   FOUND      RFADARI  F    FORMAT    T^   liccri  iiyi 
rUTvMMI     ( tin       rUI\MMI     l»U  1     TUUIlU.    nCMUMDLC    TUIxMMI     1  j    UjlU  ,    H 1 A  J 

tnf  sen 
inr  odu 

go  to  onn 
uu   i u  7UU 

TWF  OAft 

inr  oou 

A9  1 

IBRTTF    M^PRIIN  993^ 
Hi\  1  1  C    (  1  }ui\un  ,  CC  J  ) 

TNF  07ft 

inr  o / u 

9  9  3 

FORMAT  <%HU*   ONF   ^OMF   OR   Al  1    UIFTGMT^   ARF   NFGATTVF  AkY\ 
r  UI\MM  \  (jon       UIMC  ,  jUDIl    Urv    MLL    HC  lun  1  J    MI\C    NluM  1  1  Vl  ,  4DA  ) 

TNF  oon 
inr  oou 

GO  TO  900 

INF  890 

WRITE(ISCRUN,224) 

INF  900 

99A 

FORMAT (48H*  ALL  WEIGHTS  ARE  ZERO.     COMMAND  IS  NOT  EXECUTED ,36X) 

INF  910 

GO  TO  900 

INF  920 

A  9  K 
425 

WRITE(ISCRUN,225) 

INF  930 

9  9  C 

FORMAT (81H*  ARG  FOR  BESIN ,BESJN ,BESKN  GIVES  A  RESULT  TOO  LARGE/SMAINF  940 

ILL.  COMMAND  NOT  EXECUTED . ,3X) 

INF  950 

GO  TO  900 

INF  960 

420 

WRITE(ISCRUN,226) 

INF  970 

9  9  A 
2  20 

FORMAT (73H*  COLUMN  NOT  LONG  ENOUGH  TO  STORE  ALL  ELEMENTS.  ONLY  NROINF  980 

1W  WILL  BE  STORED. ,11X  ) 

INF  990 

GO  TO  900 

INF1000 

A  9  7 
42  / 

WRITE(ISCRUN,227) 

INF1010 

9  9  7 
LCI 

FORMAT (78H*  NOT  ENOUGH  DATA  ON  COL  TO  RESTORE  MATRIX/ARRAY.  DATA 

AINF1020 

1VAILABLE  WILL  BE  USED . ,6X) 

INF1025 

GO  TO  900 

INF1030 

A  O 

428 

WRITE  (ISCRUN<228) 

INF1040 

990 

FORMAT (84H*  SUM  OF  SQRS  DO  NOT  ADD  UP-ABS.  VALUE  OF  (TOTAL-ROW-COLINF1050 

1-RES.) /TOTAL  EXCEEDS  5.E-7  ) 

INF1060 

GO  TO  900 

INF1070 

429 

WRITE  (ISCRUN,229) 

INF1080 

229 

FORMAT (51H*  MORE  THAN  50  HEAD  COLUMN  COMMANDS  HAVE  BEEN  USED . ,33X) INF1090 

GO  TO  900 

INF1100 

>i  7  n 
4  JO 

WRITE  (ISCRUN,230) 

INF1110 

230 

FORMAT  (72H*  ATTEMPT  TO  PROMOTE  FROM  BELOW  NRMAX.  FIRST  ARGUMENT 

IINF1120 

IS  RESET  TO  NRMAX.,  12X) 

INF1130 

GO  TO  900 

INF1140 

114 


431  WRITE  (ISCRUN,231)  INF1150 
231      FORMAT  (53H*  ATTEMPT  TO  DEMOTE  OFF  THE  WORKSHEET .  SPILL  IS  LOST.,  INF1160 

131X)  INF1170 

GO  TO  900  INF1180 

432  GO  TO  900  INF1220 

433  WRITE  (ISCRUN,233)  INF1230 

233  FORMAT (76H*  NEGATIVE  VALUE(S)  WERE  ENCOUNTERED  BY  PARTITION  FUNCTI INF1240 
ION.     ZEROES  STORED.   ,8X)  INF1250 

GO  TO  900  INF1260 

434  WRITE  (ISCRUN,234)  INF1270 

234  FORMAT (    45H*  NEGATIVE  ABSOLUTE  TEMPERATURES  CONVERTED.   ,39X)  INF1280 
GO  TO  900  INF1290 

435  WRITE  (ISCRUN,235)  INF1300 

235  FORMAT (76H*  CAUTION,  USE  EXPERIMENTALLY  ONLY.  NOT  OPTIMUM  IN  0RDEINF1310 
1R  TO  MAKE  IT  MACHINE , 10X/84H  INDEPENDENT.  REFERENCES  -  J.B.  KRUSINF1320 
2KAL,ACM,12,92.  AND  J.H.  HALTON , SI AM  REV  .  ,  12  , 1 . )  INF1330 

GO  TO  900  INF1340 

436  WRITE  (ISCRUN,236)  INF1350 

236  FORMAT  (78H*  COMMAND  IGNORED  -  S  BEFORE  COMMAND  NAME  MEANINGLESS  IINF1360 
IF  NO  STORAGE  REQUESTED.)  INF1370 

GO  TO  900  INF1380 

437  WRITE(ISCRUN,237)  ISIGD  INF1390 

237  FORMAT (63H*  NUMBER  OF  SIGNIFICANT  DIGITS  AFTER  DECIMAL  PT  HAS  BEENINF1400 
1  SET  TO  ,I3,18X)  INF1405 

900      RETURN  INF1410 

END  INF1420 
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SUBROUTINE  INPUT  INP  10 

C         VERSION    5.00          INPUT           5/15/70  INP  20 

COMMON  /BLOCKA/  MODE ,M,KARD (83 ) ,KARG , ARG , ARG2 , NEWCD (80 ) , KRDEND        INP  30 

COMMON  /BLOCKB/  NSTMT/NSTMTX,NSTMTH,NC0M(LCOM,I0VFL,C0M(2000)  INP  40 

COMMON  /BLOCKC/  KIO , I NUN IT , ISCRAT ,KBDOUT ,KRDKNT ,LLIST  INP  50 

C  INP  60 

C         THIS  ROUTINE  HANDLES  THE  READING  OF  INPUT  RECORDS.                            INP  70 

C          IF  KIO  =  0,  INPUT  IS  CARD  IMAGE  FROM  CARD  READER  OR  TAPE.                 INP  80 

C          IF  KIO  =  1,  INPUT  IS  REAL-TIME  FROM  A  KEYBOARD.  INP  90 

C  INP  100 

KRDKNT=KRDKNT+1  INP  110 

IF  (KIO.EQ.O)  GO  TO  20  INP  120 

IF  (M0DE.EQ.3)  GO  TO  10  INP  130 

WRITE  (KBD0UT,30)  INP  140 

GO  TO  20  INP  150 

10        WRITE  (KBD0UT,40)  NSTMT  INP  160 

GO  TO  20  INP  170 

20        READ  (INUNIT.50)  NEWCD  INP  180 

KARD(1)=0  INP  190 

KARD(2)=0  INP  200 

KARD (KRDEND+3 )=46  INP  210 

CALL  OMCONV  (NEWCD , KARD (3 ) , KRDEND)  INP  220 

RETURN  INP  230 

C  INP  240 

30        FORMAT  (9H  READY      )  INP  250 

40        FORMAT  (9H  READY      ,I3,3H  /  )  INP  260 

50        FORMAT  (80A1)  INP  270 

END  INP  280 


116 


c 
c 
c 
c 
c 
c 


c 
c 
c 


c 
c 
c 


c 
c 
c 
c 


c 
c 
c 
c 


10 
20 


30 


SUBROUTINE  INTERP 

VERSION    5.00  INTERP 
* 

GENERAL  FORM  OF  COMMAND  IS 
INTERPOLATE    X  IN  COL  ++  Y 
,  ,  VALUES  OF    XP  IN  COL  ++ 


5/15/70 


IN  COL  33  LENGTH=, ,  FOR  THE  FIRST 
USE  ,,  POINTS    STORE  IN  COL  33 


COMMON  /BLOCRC/  NRC  , RC  ( 12600 ) 

COMMON  /BLOCKD/  IARGS(IOO) ,KIND(100) ,ARGTAB (100) ,NRMAX ,NR0W,NC0L , 
1ARGS,VWXYZ(8) .NERROR 
COMMON  /BLOCKC/  KIO , I NUN IT , ISCRAT ,KBDOUT ,KRDKNT , LLIST 
DIMENSION  ARGS(IOO) 
EQUIVALENCE  (ARGS (1 ) ,RC  (12501 ) ) 
COMMON  /SCRAT/  NS ,NS2 ,A  (13500) 


INT 
INT 
INT 
INT 
INT 
INT 
INT 
INT 
NINT 


10 
20 
30 
40 
50 
60 
70 
80 
90 


NUMBER  AND  MODE  OF  ARGUMENTS 


CHECK  TO  SEE  IF  WE  HAVE  CORRECT 

IF  (NARGS.NE.7)  CALL  ERROR  (10) 

J=NARGS 

CALL  CKIND  (J) 

IF  (J.NE.O)  CALL  ERROR  (3) 


CHECK  NO.  OF  POINTS    LESS  THAN  OR  EQUAL  TO  NRMAX  AND  POSITIVE 
* 

IF  (IARGS(3) .LT.0.0R.IARGS(4) .LT.O)  CALL  ERROR  (3) 

IF  (IARGS(3) .GT.NROW. OR. IARGS(4) .GT. NRMAX)  CALL  ERROR  (3) 

CHECK  TO  SEE  IF  WE  HAVE  MORE  THAN  TWO  ENTRIES  IN  TABLE 
COMPUTE  COLUMN  ADDRESSES 

IF  (IARGS(3) .LT.2)  CALL  ERROR  (3) 

LXY=IARGS(3) 

LXP=IARGS(4) 

IARGS(3)=IARGS(5) 

IARGS(4)=IARGS(7) 

NARGS=4 

CALL  CHKCOL  (J) 

IF  (J.NE.O)  CALL  ERROR  (11) 
* 

CHECK  TO  SEE  IF  WE  EXCEED  SCRATCH  AREA 
CHECK  FOR  PREVIOUS  ERRORS 

INDRV=0 

IF  (IARGS(6)-LXY)  20,20,10 

IARGS(6)=LXY 

INDRV=1 

IF  (IARGS(6)**2+3*IARGS(6)+LXP.LE.NS)  GO  TO  30 

C=1.0-4.0*FL0AT(NS-LXP) 

I=FSQRT(C) 

IARGS(6)=(-l+I)/2 

INDRV=2 

IA1=IARGS(1) 

IA2=IARGS(2) 

IA3=IARGS(3) 

IA4=3*IARGS(6)+LXP+1 

CALL  INTRP  (RC(IAl) ,RC(IA2) ,LXY,RC(IA3) ,A(1) ,LXP, IARGS (6) ,A(LXP+1 
1,A(IA4) ,IND) 
STORE  RESULTS 
IA3=IARGS(4) 


INT  100 
INT  110 
INT  120 
INT  130 
INT  140 
INT  150 
INT  160 
INT  170 
INT  180 
INT  190 
INT  200 
INT  210 
INT  220 
INT  230 
INT  240 
INT  250 
INT  260 
INT  270 
INT  280 
INT  290 
INT  300 
INT  310 
INT  320 
INT  330 
INT  340 
INT  350 
INT  360 
INT  370 
INT  380 
INT  390 
INT  400 
INT  410 
INT  420 
INT  430 
INT  440 
INT  450 
INT  460 
INT  470 
INT  480 
INT  490 
INT  500 
INT  510 
INT  520 
INT  530 
INT  540 
INT  550 
)INT  560 
INT  570 
INT  580 
INT  590 
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DO  40  I=1,LXP  INT  600 

RC(IA3)=A(I)  INT  610 

IA3=IA3+1  INT  620 

40        CONTINUE  INT  630 

IF  ( INDRV .EQ .0 .AND . IND .EQ . 0 )  RETURN  INT  640 

IF  (INDRV-1)  70,50,60  INT  650 

50        WRITE  (ISCRAT,80)  INT  660 

GO  TO  70  INT  670 

60        WRITE  (ISCRAT,90)  INT  680 

70        IF  (IND.EQ.O)  RETURN  INT  690 

WRITE  (ISCRAT,100)  INT  700 

RETURN  INT  710 

C  INT  720 

80        FORMAT  (6X , 20 ( 1H+) ,39H0RDER  OF  INTERPOLATION  EQUALS  LIST  SIZE,19X)INT  730 

90        FORMAT  (6X , 20 (1H+) , 53H0RDER  OF  INTERP  WAS  RESET  DUE  TO  SIZE  OF  SCRINT  740 

1ATCH  AREA , 5X)  INT  750 
100      FORMAT  (6X,20(1H+) ,42HEXTRAP0LATI0N  DONE  FOR  MORE  THAN  ONE  DELTA , 1INT  760 

16X)  INT  770 

END  INT  780 
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SUBROUTINE  INTRP  (X ,Y (NLIST ,X1 .RESULT ,NX1 ,NORD , S , SA , IND ) 

INR 

10 

c 

VERSION    5.00         INTRP  5/15/70 

INR 

20 

c 

CALLING  SEQUENCE 

INR 

30 

c 

SUBROUTINE  INTRP (X , Y ,NLIST ,X1 , RESULT ,NX1 ,NORD ,S ,SA ,  IND) 

INR 

40 

c 

INR 

50 

c 

X    THE  INDEPENDENT  VALUE  OF  THE  TABLE.  MUST 

BE  IN  ASCENDING  OR 

INR 

60 

c 

DESCENDING  ORDER.     NEED    NOT  BE  EVENLY  SPACED 

INR 

70 

c 

Y    THE  DEPENDENT  VALUE  OF  THE  TABLE 

INR 

80 

c 

NLIST        LENGTH  OF    X  OR  Y 

INR 

90 

c 

XI             VALUES  TO  BE  INTERPOLATED 

INR 

100 

c 

RESULT      RESULT  FROM  INTERPOLATION 

INR 

110 

c 

NX1           LENGTH  OF  XI  VECTOR 

INR 

120 

c 

NORD         ORDER  OF  INTERPOLATION 

INR 

130 

c 

S              SCRATCH  AREA  S(3*N0RD) 

INR 

140 

c 

SA             SCRATCH  AREA    SA (NORD ,N0RD ) 

INR 

150 

c 

IND  INDICATOR 

INR 

160 

c 

IND=0    EVERYTHING  FINE 

INR 

170 

c 

IND=2    EXTRAPOLATION  AND  MORE  THEN  ONE 

DELTA 

INR 

180 

c 

INR 

190 

DIMENSION  X(l),  Y(l),  Xl(l),  RESULT(l),  S(l) 

,  SA (NORD , NORD) 

INR 

200 

INDA=0 

INR 

210 

IND=0 

INR 

220 

NRD=N0RD-1 

INR 

230 

NDIR=1 

INR 

240 

IF  (X(l) .GE.X(2))  NDIR=2 

INR 

250 

1=1 

INR 

260 

DO  220  11=1, NX1 

INR 

270 

IC=0 

INR 

280 

XA=X1(II) 

INR 

290 

GO  TO  (10,180) ,  NDIR 

INR 

300 

10 

IF  (XA-X(l))  20,160,30 

INR 

310 

20 

IF  (ABS(XA-X(1)) .GT.ABS(X(1)-X(2)))  INDA=2 

INR 

320 

IC=1 

INR 

330 

IA=1 

INR 

340 

GO  TO  80 

INR 

350 

30 

DO  40  IA=I, NLIST 

INR 

360 

IF  (X(IA)-XA)  40,170,60 

INR 

370 

40 

CONTINUE 

INR 

380 

50 

IF  (ABS(X(NLIST)-XA) .GT .ABS (X (NLIST)-X (NLIST 

-1)))  INDA=2 

INR 

IE=1 

INR 

400 

IA=NLIST-NRD 

INR 

410 

IC=1 

INR 

420 

GO  TO  80 

INR 

430 

60 

IA=IA-1 

INR 

440 

IF  (X(IA)-XA)  70,170,60 

INR 

450 

70 

IF  (IA+NRD.LE. NLIST)  GO  TO  80 

INR 

460 

IC=1 

INR 

470 

IA=NLIST-NRD 

INR 

480 

80 

IF  (NRD.GT.l)  GO  TO  90 

INR 

490 

TEMP=(XA-X ( IA) ) / (X ( I A+l ) -X ( IA ) ) 

- 

INR 

500 

RESULT(II)=Y(IA)+(Y(IA+1)-Y(IA))*TEMP 

INR 

510 

GO  TO  220 

INR 

520 

90 

IF  (IC.NE.O)  GO  TO  100 

INR 

530 

IA=IA-NRD/2 

INR 

540 

IF  (IA.LE.O)  IA=1 

INR 

550 

100 

NA=IA+NRD 

INR 

560 

PR0D=1. 

INR 

570 

IZ=1 

INR 

580 

IZA=N0R0+1 

INR 

590 
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DO  110  IB=IA,NA 

INR 

600 

S(IZ)=X(IB) 

INR 

610 

S(IZA)=XA-X(IB) 

INR 

620 

PROD=PROD*S(IZA) 

INR 

630 

IZ=IZ+1 

INR 

640 

110 

IZA=IZA+1 

INR 

650 

NB=NRD+1 

INR 

660 

DO  120  IAR=2,NB 

INR 

670 

DO  120  IBR=IAR,NB 

INR 

680 

SA ( IBR-1 , IAR-1 )=S ( IAR-1 )-S (I BR) 

INR 

690 

120 

SA(IAR-1,IBR)=(-SA(IBR-1,IAR-1) ) 

INR 

700 

IZB=IZA 

INR 

710 

IZC=N0RD+1 

INR 

720 

DO  140  IAR=1,NB 

INR 

730 

SUM=S(IZC) 

INR 

740 

DO  130  IBR=1 ,NRD 

INR 

750 

130 

SUM=SUM*SA(IBR,IAR) 

INR 

760 

S (IZA)=PR0D/SUM 

INR 

770 

IZC=IZC+1 

INR 

780 

140 

IZA=IZA+1 

INR 

790 

R=0  .0 

INR 

800 

I  AX=I  A 

INR 

810 

DO  150  IX=1 , NORD 

INR 

820 

R=R+S(IZB)*Y(IAX) 

INR 

830 

IAX=IAX+1 

INR 

840 

150 

IZB=IZB+1 

INR 

850 

RESULT(II)=R 

INR 

860 

GO  TO  220 

INR 

870 

160 

RESULT (II )=Y(1) 

INR 

880 

IA=1 

INR 

890 

GO  TO  220 

INR 

900 

170 

RESULT(II)=Y(IA) 

INR 

910 

GO  TO  220 

INR 

920 

180 

IF  (XA-X(l))  190,160,30 

INR 

930 

190 

DO  200  IA=I ,NLIST 

INR 

940 

IF  (XA-X(IA))  200,170,210 

INR 

950 

200 

CONTINUE 

INR 

960 

GO  TO  50 

INR 

970 

210 

I A=I A-l 

INR 

980 

IF  (XA-X(IA))  70,170,210 

INR 

990 

220 

I=IA 

INR1000 

IND=IND+INDA 

INR1010 

RETURN 

INR1020 

END 

INR1030 

120 
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SUBROUTINE  INVCHK  (A ,M,N , AINV , Ml , Y , L2 , ERR , IND ) 
VERSION    5.00  INVCHK  5/15/70 

INVCHK  FOR  OMNI TAB    UNIVAC  1108      S.  PEAVY  5/24/67 
THIS  SUBROUTINE  INVERTS  A  MATRIX  AND  PROVIDES  ALL  THE  CHECKS  DESCR 
IN  PAC-1 

A  IS  THE  MATRIX  TO  BE  INVERTED 

M  IS  THE  SIZE  OF  A  AS  DIMENSIONED  IN  THE  CALLING  PROGRAM    A ( M , M) 


N  IS  THE  SIZE  OF  A  TO  BE  INVERTED 
N  LESS  THAN  OR  =M-1 

AINV  WILL  CONTAIN  THE  INVERTED  MATRIX  IF  INVERSION  IS  OBTAINABLE 

Ml  IS  THE  SIZE  OF  AINV  AS  DIMENSIONED  IN  THE  CALLING  PROGRAM 
AINV(M1,2*M1)  Ml  MUST  BE  GREATER  OR  =N+1 

AINV  MUST  HAVE  TWICE  AS  MANY  COLUMNS  AS  ROWS 
A  AND  AINV  CANNOT  BE  SAME  OR  EQUIVALENT 

ERR    WILL  CONTAIN  THE  3  WAYS  OF  EVALUATING  NORM  CHECKS 
ERR  IS    A  DIMENSIONED  AS  ERR  (3 ) 

IND  IS  AN  INDICATOR 

IND=0    MATRIX  INVERTED  AND  ERROR  CHECKS  MADE 
IND=1    MATRIX  SINGULAR 


COLUMN  AINV(N+1,I) 
THE  SUM  CHECKS+1. 


1=1,  N    WILL  CONTAIN  THE  ERROR  BOUND  OF 


70 


DIMENSION  A (M,M) ,  AINV(Ml.Ml),  ERR  (3 )  ,  AN0RM(2,3) 

DIMENSION  Y (N) 

DATA  ZERO/0.0/, ONE/1. 0/ 

NA=N 

DO  20  1=1, NA 
DO  20  J=1,NA 
AINV(J,I)=A(J,I) 
NB=NA 

IF  (L2.EQ.1)  GO  TO  40 

NB=NB+1 

DO  30  1=1, NA 

AINV(I,NA+1)=Y(I) 

AINV(NA+1,I)=ZER0 

AINV(NA+1,NA+1)=-0NE 

NA=NA+1 

DO  60  1=1, NA 

SUM-ZERO 

AINV(NA+1,I)=ZER0 

DO  50  J=1,NA 

SUM=SUM+AINV(I,J) 

AINV(I,NA+1)=-SUM 

AINV(NA+1,NA+1)=0NE 

NB=NB+1 

CALL  SPINV  (AINV, NB , Ml, IND) 

IF  (IND.NE.O)  RETURN 

DO  140  K=l,2 

DO  70  1=1,3 

ANORM(K,I)=ZERO 

DO  130  1=1, N 


INK 
INK 
INK 
INK 
INK 
INK 
INK 
INK 
INK 


10 
20 
30 
40 
50 
60 
70 
80 
90 


INK  100 
INK  110 
INK  120 
INK  130 
INK  140 
INK  150 
INK  160 
INK  170 
INK  180 
INK  190 
INK  200 
INK  210 
INK  220 
INK  230 
INK  240 
INK  250 
INK  260 
INK  270 
INK  280 
INK  290 
INK  300 
INK  310 
INK  320 
INK  330 
INK  340 
INK  350 
INK  360 
INK  370 
INK  380 
INK  390 
INK  400 
INK  410 
INK  420 
INK  430 
INK  440 
INK  450 
INK  460 
INK  470 
INK  480 
INK  490 
INK  500 
INK  510 
INK  520 
INK  530 
INK  540 
INK  550 
INK  560 
INK  570 
INK  580 
INK  590 
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SUM=ZER0 

INK 

600 

00  120  J=1,N 

INK 

610 

60  TO  (80 ,90)  ,  K 

INK 

620 

80 

TEMP=ABS(AINV(I ,J) ) 

INK 

630 

60  TO  110 

INK 

640 

90 

TEMP=ZERO 

INK 

650 

DO  100  L=l  ,N 

INK 

660 

100 

TEMP=TEMP+A ( I , L) *AINV (L , J ) 

INK 

670 

IF  (I.EQ.J)  TEMP=ONE-TEMP 

INK 

680 

TEMP=ABS (TEMP) 

INK 

690 

110 

AN0RM(K,1)=AN0RM(K,1)+TEMP**2 

INK 

700 

IF  (AN0RM(K,2) .LT.TEMP)  ANORM(K , 2 )=TEMP 

INK 

710 

120 

SUM=SUM+TEMP 

INK 

720 

IF  (AN0RM(K,3) .IT. SUM)  ANORM(K , 3 )=SUM 

INK 

730 

130 

CONTINUE 

INK 

740 

AN0RM(K,1)=FSQRT(AN0RM(K,1) ) 

INK 

750 

140 

AN0RM(K,2)=FL0AT(N)*AN0RM(K,2) 

INK 

760 

DO  150  K=l,3 

INK 

770 

150 

ERR (K)=(AN0RM(1 ,K)*AN0RM(2 ,K) ) / (1 .-AN0RM(2 ,K) ) 

INK 

780 

RETURN 

INK 

790 

END 

INK 

800 
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c 
c 
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SUBROUTINE  INVCOR  (A , M, N , AINV , Ml , Y , L2 , ERR , IND ) 
VERSION    5.00  INVCOR  5/15/70 

INVCOR  FOR  OMNITAB    UNIVAC  1108      S.  PEAVY  5/24/67 
THIS  SUBROUTINE  INVERTS  A  MATRIX  AND  PROVIDES  ALL  THE  CHECKS  DESCR 
IN  PAC-1 

A  IS  THE  MATRIX  TO  BE  INVERTED 

M  IS  THE  SIZE  OF  A  AS  DIMENSIONED  IN  THE  CALLING  PROGRAM    A (M,M) 


N  IS  THE  SIZE  OF  A  TO  BE  INVERTED 
N  LESS  THAN  OR  =M-1 

AINV  WILL  CONTAIN  THE  INVERTED  MATRIX  IF  INVERSION  IS  OBTAINABLE 

Ml  IS  THE  SIZE  OF  AINV  AS  DIMENSIONED  IN  THE  CALLING  PROGRAM 
AINV(M1,2*M1)  Ml  MUST  BE  GREATER  OR  =N+1 

AINV  MUST  HAVE  TWICE  AS  MANY  COLUMNS  AS  ROWS 
A  AND  AINV  CANNOT  BE  SAME  OR  EQUIVALENT 

ERR    WILL  CONTAIN  THE  3  WAYS  OF  EVALUATING  NORM  CHECKS 
ERR  IS    A  DIMENSIONED  AS  ERR (3 ) 

IND  IS  AN  INDICATOR 

IND=0    MATRIX  INVERTED  AND  ERROR  CHECKS  MADE 
IND=1    MATRIX  SINGULAR 


COLUMN  AINV(N+1,I) 
THE  SUM  CHECKS+1. 


1=1  N    WILL  CONTAIN  THE  ERROR  BOUND  OF 


70 


DIMENSION  A (M,M) ,  AINV(M1,M1) ,  ERR  (3 )  ,  AN0RM(2,3) 

DIMENSION  Y (N) 

DATA  ZERO/0.0/, ONE/1.0/ 

NA=N 

DO  20  1=1, NA 
DO  20  J=1,NA 
AINV(J,I)=A(J,I) 
NB=NA 

IF  (L2.EQ.1)  GO  TO  40 

NB=NB+1 

DO  30  1=1, NA 

AINV(I,NA+1)=Y(I) 

AINV(NA+1,I )=ZERO 

AINV(NA+1,NA+1)=-0NE 

NA=NA+1 

DO  60  1=1, NA 

SUM=ZERO 

AINV(NA+1,I)=ZER0 
DO  50  J=1,NA 
SUM=SUM+AINV(I ,J) 
AINV(I,NA+1)=-SUM 
AINV(NA+1,NA+1)=0NE 
NB=NB+1 

CALL  CSPINV  (AINV, NB, Ml, IND) 

IF  (IND.NE.O)  RETURN 

DO  140  K=l,2 

DO  70  1=1,3 

ANORM(K,I)=ZERO 

DO  130  1=1, N 
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INC  100 
INC  110 
INC  120 
INC  130 
INC  140 
INC  150 
INC  160 
INC  170 
INC  180 
INC  190 
INC  200 
INC  210 
INC  220 
INC  230 
INC  240 
INC  250 
INC  260 
INC  270 
INC  280 
INC  290 
INC  300 
INC  310 
INC  320 
INC  330 
INC  340 
INC  350 
INC  360 
INC  370 
INC  380 
INC  390 
INC  400 
INC  410 
INC  420 
INC  430 
INC  440 
INC  450 
INC  460 
INC  470 
INC  480 
INC  490 
INC  500 
INC  510 
INC  520 
INC  530 
INC  540 
INC  550 
INC  560 
INC  570 
INC  580 
INC  590 
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SUBROUTINE  INVERT 

INV 

10 

c 

VERSION    5.00          INVERT  5/15/70 

INV 

20 

c 

MATRIX  INVERSION,   SOLUTION  OF  SYSTEM  OF  EQUATIONS 

INV 

30 
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S  PEAVY  5/22/67 
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SUBROUTINE  HERAT 
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VERSION    5.00  ITERAT 
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ITE 
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ITE 
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ITE 

40 
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ITE 

60 

DIMENSION  ARGS(IOO) 

ITE 

70 
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ITE 

80 
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ITE 
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++ 
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Y 

IN 

++, 
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++ 
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INDICATED 

STORE 

ITE 
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ARE  NEW  X  , AVERAGE 

BRACKETING  X,ITE 
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SUCCESSFUL  Y 
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220 
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T  TF 

230 

20 
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240 

30 
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40 
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260 

50 

M A  DC C  "7 
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1  Tt 

270 

DO  60  1=5,7 
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280 
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1  1  t 
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60 
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300 
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T  T  C 
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310 

70 

K=17 

T  T  C 

320 

GO  TO  20 
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1  I  L 
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80 

IF  (L2-3)  10,90,10 
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1  1  t 
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90 

IARGS(7)=IARGS(5) 
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1  1  t 
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KIND(7)=KIND(5) 

ITE 
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IF  (NARGS-6 )  100,110,10 

t  t  r~ 

ITE 
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100 

NARGS=6 

ITE 

380 

IARGS(6)=IARGS(5) 

ITE 
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KIND(6)=KIND(5) 

ITE 
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IARGS(5)=IARGS(4) 

ITE 
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KIND(5)=KIND(4) 

ITE 

420 

GO  TO  140 

ITE 
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110 
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ITE 
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ITE 
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GO  TO  20 

ITE 

460 
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INSERT=IARGS(4) 

ITE 
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ITE 

480 

140 

IF  (INSERT-1)  120,150,150 

ITE 

490 
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IF  (NROW-INSERT-2)  70,160,160 

ITE 
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IF  (KIND(3))  170,120,170 

ITE 
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ITE 
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ITE 
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ITE 
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CALL  CHKCOL  (J) 

ITE 
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ITE 

560 
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IF  (NERROR.NE.O)     GO  TO  30 

ITE 
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IF  (NRMAX-1)  200,210,220 

ITE 

580 

200 

K=9 

ITE 

590 
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GO  TO  20 

ITE  600 

210 

K=215 

ITE  610 

GO  TO  20 

ITE  620 

220 
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ITE  630 
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ITE  640 
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I2=IARGS(2)+I-1 

ITE  830 
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ITE  910 

I0VFL=0 
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350 
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IF  (POINT-A(K))  370,390,440 

ITE1190 
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1  =  1-1 

T  TF?  'iAft 
1  1  LA  J*JU 

1        1  7 

L=L-1 

T  TF?  %  fi(\ 
1  1  LA  J  D  U 

GO  TO  840 

ITE2360 
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810 

IF   (A(L)-A(K))  830,840,890 

ITE2370 

820 

IF   (A(L)-A(K))  890,840,830 

ITE2380 

830 

CONTINUE 

ITE2390 

GO  TO  950 

ITE2400 

840 

IF   (NR0W-M-IND2 )  850,860,860 

ITE2410 

850 

I0VFL=1 

ITE2420 

GO  TO  880 

ITE2430 

860 

DO  870  J=1,IND2 

ITE2440 

M=M+1 

ITE2450 

11=11+1 

ITE2460 

870 

RC(I1)=A(I) 

ITE2470 

880 

M1=M1+1 

ITE2480 

12=12+1 

ITE2490 

RC(I2)=A(I) 

ITE2500 

13=13+1 

ITE2510 

RC(I3)=A(L) 

ITE2520 

GO  TO  940 

ITE2530 

890 

IF   (NR0W-M-IND2 )  900,910,910 

ITE2540 

900 

I0VFL=1 

ITE2550 

GO  TO  930 

ITE2560 

910 

DELT=(A(I)-A(I-1) ) /DIV 

ITE2570 

M=M+1 

ITE2580 

11=11+1 

ITE2590 

RC(I1)=A(I-1) 

ITE2600 

DO  920  J=l, INSERT 

ITE2610 

M=M+1 

ITE2620 

11=11+1 

ITE2630 

920 

RC(I1)=RC(I1-1)+DELT 

ITE2640 

M=M+1 

ITE2650 

11=11+1 

ITE2660 

RC(I1)=A(I) 

ITE2670 

930 

M1=M1+1 

ITE2680 

12=12+1 

ITE2690 

RC(I2)=(A(I)+A(I-l))/2.0 

ITE2700 

13=13+1 

ITE2710 

RC(I3)=(A(L)+A(L-1) ) /2.0 

ITE2720 

940 

14=14+1 

ITE2730 

RC(I4)=A(K) 

ITE2740 

IF   (NR0W-M1)  470,470,960 

ITE2750 

950 

CONTINUE 

ITE2760 

960 

CONTINUE 

ITE2770 

GO  TO  750 

ITE2780 

END 

ITE2790 
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c 
c 

c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 


BLOCK  DATA 
VERSION  5.00 
BLOCK  DATA 


LBCONS 
LBCONS 


5/15/70 


C 

c 
c 
c 
c 
c 
c 
c 
c 
c 


THESE  CONSTANTS  MAY  HAVE  TO  BE  CHANGED  FOR  OTHER  COMPUTERS  OR 
LIBRARY  ROUTINES 


LBC 
LBC 
LBC 
LBC 
LBC 
LBC 
LBC 


10 
20 
30 
40 
50 
60 
70 
80 
90 


DSNCOS  IS  USED  BY  DOUBLE  PRECISION  SIN  AND  COS  FUNCTIONS  IN  ORDER  LBC 
TO  TRAP    IF  ARGUMENT  BECOMES  TOO  LARGE  LBC 

LBC  100 

XTRIG    IS  USED  BY  FSIN,FCOS  FUNCTIONS  IN  ORDER  TO  TRAP  IF  ARGUMENTLBC  110 


BECOMES  TOO  LARGE 


XEXP 


DXEXP 


ER 


NBM 


TRRTPI 


ISIGD 


LBC  120 

LBC  130 

LBC  140 

LBC  150 

LBC  160 

LBC  170 

LBC  180 

LBC  190 

LBC  210 

LBC  220 

LBC  230 

LBC  240 

LBC  250 

LBC  260 

LBC  270 

LBC  280 

IS  USED  BY  SUBROUTINE  ERRINT  AND  IS  THE  VALUE  2.0/SQRT(PI)  LBC  290 

LBC  300 

IS  USED  BY  SUBROUTINE  FIXFLO  AND  INFERR,  NO.  OF  SIGNIFICANTLBC  310 


IS  USED  BY  FEXP  FUNCION  IN  ORDER  TO  TRAP  IF  ARGUMENT 

BECOMES  TOO  LARGE 

IS  USED  BY  FDEXP  FUNCTION  IN  ORDER  TO  TRAP  IF  ARGUMENT 

BECOMES  TOO  LARGE 

IS  USED  BY  SUBROUTINE  CSPINV  TO  CHECK  ON  A  COMPUTER  ZERO 

IS  USED  BY  SUBROUTINE  ERRINT  AND  IS  THE  NUMBER  OF  BINARY 

BITS  IN  THE  CHARACTERISTIC  OF  A  DOUBLE  PRECISION  NUMBER 

IS  USED  BY  SUBROUTINE  ERRINT  AND  IS  THE  NUMBER  OF  BINARY 

BITS  IN  THE  MANTISSA  OF  A  DOUBLE  PRECISION  NUMBER 


DIGITS  I/O  SUB.  CAN  PRINT  AFTER  DECIMAL  POINT  ISIGD=8 


DOUBLE  PRECISION  DSNCOS  ,  DXEXP , TRRTPI 
COMMON /CONSLB/XTRIG , XEXP 
COMMON /C0NLB2 /ER , ISIGD 

COMMON/CONSTS/PI ,E ,HALFPI , DEG , RAD , XALOG 

COMMON/DCQNLB/DSNCOS, DXEXP 

C0MM0N/DC0NL2 /TRRTPI ,NBC ,NBM 

DATA  DSNCOS/3 .5D16/ .DXEXP/704 .000/ 

DATA  NBC/ 11 / ,NBM/60/ , TRRTPI /l . 128379167095512574D0 / 

DATA  XTRIG/3.3E7/,XEXP/88.0  / 

DATA  ER/l.E-8/,ISIGD/8/ 

THIS  BLOCK  DEFINES  CONSTANTS  TO  BE  USED  THROUGHOUT  OMNI TAB 
WHOSE  VALUE  (ACCURACY)  WILL  HAVE  TO  BE  CHANGED  FOR  OTHER 
COMPUTERS 

PI=3. 14159265  (VALUE  OF  PI) 

E,  2.71821818  (BASE  OF  NATURAL  LOGS) 

HALFPI=1. 5707963  (VALUE  OF  PI/2) 

DEG=  57.2957795  (NUMBER  OF  DEGREES  IN  ONE  RADIAN) 

RAD=  .0174532925  (NUMBER  OF  RADIANS  IN  ONE  DEGREE) 

XALOG=  38.  (EXPONENT  BOUND) 

DATA  PI ,E,HALFPI ,DEG,RAD, XALOG/ 
1  3.14159265,2 .7182818,1.5707963,57 .2957795, .0174532925,38./ 
END 


LBC  320 
LBC  330 
LBC  340 
LBC  350 
LBC  360 
LBC  370 
LBC  380 
LBC  390 
LBC  400 
LBC  410 
LBC  420 
LBC  430 
LBC  440 
LBC  450 
LBC  460 
LBC  470 
LBC  480 
LBC  490 
LBC  500 
LBC  510 
LBC  520 
LBC  530 
LBC  540 
LBC  550 
LBC  560 
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SUBROUTINE  LIST  (K)  LIS  10 

C         VERSION    5.00         LIST             5/15/70  LIS  20 

C         WRITTEN  BY  R  VARNER        3/14/68  LIS  30 

C         K=0      COMMAND  IS  LIST  LIS  40 

C         K=l      COMMAND  IS  NOLIST  LIS  50 

COMMON  /BLOCKC/  KIO , INUNIT , ISCRAT , KBDOUT ,KRDKNT , LLI ST  LIS  60 

COMMON  /BLOCRC/  NRC  , RC  (12600 )  LIS  70 
COMMON  /BLOCKD/  IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NLIS  80 

1ARGS ,VWXYZ (8) ,NERROR  LIS  90 

DIMENSION  ARGS(IOO)  LIS  100 

EQUIVALENCE  (ARGS (1) ,RC  (12501) )  LIS  110 

IF  (K.EQ.O)  GO  TO  20  LIS  120 

C         NO  LIST  OR  NOLIST  LIS  130 

IARGS(1)=0  LIS  140 

10        IF  (NERROR.EQ.O)  LLI ST=I ARGS ( 1 )  LIS  150 

WRITE  (ISCRAT, 30)  IARGS(l)  LIS  160 

RETURN  LIS  170 

C  LIS  180 

C         LIST  (WITH  NO  ARGUMENTS)  =  LIST  3  LIS  190 

C         LIST  0  =  NO  LISTING  LIS  200 

C         LIST  1  =  LIST  ONLY  INFORMATIVE  DIAGS.  LIS  210 

C         LIST  2  =  LIST  ONLY  ARITH.  ERR  LIS  220 

C  LIST  3  =  LIST  BOTH  TYPES  OF  ERRORS  LIS  230 
C         LIST=4  SUPPRESS  BOTH  ARITHMETIC  ERRORS  AND  INFORMATIVE  DIAGNOSTICSLIS  235 

C         IF  A  FATAL  ERROR  OCCURS,  LLIST  IS  SET  TO  AND  KEPT  AT  3  LIS  240 

20        IF (NARGS .EQ . 0 .OR . IARGS (1 ) . LT . 0 .OR . IARGS  (1 )  .GT  .4)  IARGS(1)=3  LIS  250 

GO  TO  10  LIS  260 

C  LIS  270 

30        FORMAT  (1H,,I1,82X)  LIS  280 

END  LIS  290 


FUNCTION  LOCATE  (L)  LOC  10 

C         VERSION    5.00         LOCATE         5/15/70    ■  LOC  20 

COMMON  /BLOCKB /  NSTMT , NSTMTX , NSTMTH ,NCOM, LCOM, IOVFL , COM ( 2000 )  LOC  30 

C  LOC  40 

C         THIS  FUNCTION  SEARCHES  THE  LIST  OF  STORED  COMMANDS  TO  SEE  IF  ONE    LOC  50 

C         WITH  STATEMENT  NUMBER  L  EXISTS.     IF  IT  DOES,  RETURN  ITS  LOCATION.  LOC  60 

C         IF  IT  DOESN'T  EXIST,  RETURN  NEGATIVE  THE  LOCATION  OF  THE  NEXT  LOC  70 

C         HIGHER  STATEMENT  NUMBER.  LOC  80 

C  LOC  90 

1=1  LOC  100 

AL=L  LOC  105 

10        IF  (COM(I)-AL)  20,30,40  LOC  110 

20        I=I+IFIX(C0M(I+1))  LOC  120 

GO  TO  10  LOC  130 

30        LOCATE=I  LOC  140 

GO  TO  50  LOC  150 

40        LOCATE=-I  LOC  160 

50        RETURN  LOC  170 

END  LOC  180 
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C         BLOCK    DATA  LOOKTB 

C         VERSION    5.00         LOOKTB  5/15/70 
BLOCK  DATA 

COMMON /I CODE/  NIR ,NID ,NIRD (LIR , LID ,LIRD 
COMMON/CODE/IALPH  (6),NALPH  (5),  ID  (9  ,3 )  , 
1  IR  (300,4) ,IRD(30,6) 
C  ****  THE  FOLLOWING  CARDS  ARE  NEEDED  ONLY  FOR  TAPE  OPERATIONS 
COMMON/ICODTP/NITP,  LITP 
C0MM0N/C0DETP/ITP(10,4) 


LOT 
LOT 
LOT 
LOT 
LOT 
LOT 
LOT 
LOT 
LOT 


10 
20 
30 
40 
50 
60 
70 
80 
90 


C 

c 


ADD  SUB 


SUBTRA  MULT      MULTIP  DIV 


DIVIDE  RAISE 


C 

c 
c 

C 

c 

C 

c 
c 


DATA  IR(1,1),IR(1,2),IR(1,3),IR(1,4),IR(2,1),IR(2,2),IR(2,3), 
1  IR (2 ,4) , IR (3 , 1) ,IR(3,2) , IR (3 ,3) ,IR(3,4) ,IR(4,1) ,IR(4,2)  ,IR(4,3) , 
2IR(4,4) ,IR(5,1) ,IR(5,2) ,IR(5,3) ,IR(5,4) ,IR(6,1) ,IR(6,2)  ,IR(6,3) , 
3  IR(6,4) , IR (7 ,1) , IR (7,2) ,IR(7,3) ,IR(7,4) ,IR(8,1) ,IR(8,2)  ,  IR  (8 ,3) , 
4IR(8,4)  / 

5  841,0,11,1,14420,  0,11,2,14420,15067,11,2, 

6  10056,14580,11,3,10056,14839,11,3,3181,  0,11,4, 

7  3181,6674,11,4,13158,13986,11,5/ 


SIN        COS  TAN 
ATAN  ACOT 
5IND      COSD  TAND 

SQRT  EXP 
SINH      COSH  TANH 
ABSULO  INTEGE  FRACTI 


COT 


ASIN 


ACQS 


COTD      ASIND    ACOSD    ATAND  ACOTD 

EXPONE  NEGEXP  LOG        LOGE      LOGTEN  ANTILO 

COTH      ASINH    ACOSH    ATANH    ACOTH  ABS 


DATA 
IR(10 
IR  (12 
IR(14 
IR  (15 
IR  (17 
IR  (19 
IR  (21 

8  IR  (22 

9  IR (24 
A  14108 
B  2612 

0 

1270 
14108 
2612 
DATA 


IR 
IR 
I R 
I R 
IR 
I  R 
IP 
IR 
IR 
IR 
0 
0 
0 

,10206 
,  2916 
,  2916 
IR 


,3) 
,2) 
,1) 
,4) 
,3) 
,2) 

,1) 
,4) 
,3) 


IR  (27 
IR  (29 
IR  (31 
IR  (32 
IR(34 
IR  (36 
IR  (38 

8  IR  (39 

9  IR  (41 
A  IR(43 
B  IR(45 
C  825 
D 

E 


,3) 
,2) 

,1) 
,4) 
,3) 
,2) 

,1) 
,4) 
,3) 
,2) 
,1) 


IR 
IR 
IR 
IR 
IR 
IR 
IR 
IR 
IR 
IR 
IR 


9,1) 
10,4) 
12,3) 
14,2) 
16,1) 
17,4) 
19,3) 
21,2) 
23,1) 
24,4) 
12,1, 


12 
0 
12 
12 


,13959, 


12,12 
26,1) 
27,4) 
29,3) 
31,2) 
33,1) 
34,4) 
36,3) 
38,2) 
40,1) 
41,4) 
43,3) 
45,2) 
12,14 


IR(  9, 

IR  (11 , 
IR  (12, 

IR(14, 
IR  (16 , 
IR  (18, 
IR (19 , 
IR (21 , 
IR (23  , 
IR(25, 
2611, 
0, 
825, 
0, 
2611, 
1251, 
IR (26 , 
IR (28 , 
IR (29 , 
IR  (31 , 
IR(33, 
IR  (35 , 
IR (36 , 
IR (38 , 
IR(40, 
IR(42, 
IR  (43  , 
IR  (45 , 
1270, 


2) 
1) 
4) 
3) 
2) 
1) 
4) 

3) 
2) 
1) 


IR(  9 
IR  (11 
IR  (13 
IR(14 
IR  (16 
IR  (18 
IR  (20 
IR  (21 
IR  (23 
IR  (25 
0,12, 
0,  0 
13851,12 
0,  0 
2916,12 
10314,12 
2)  ,  IR (26 
, IR  (28 
,IR(30 
, IR  (31 
, IR (33 
, IR (35 
, IR (37 
, IR (38 
, IR (40 
, IR (42 
,IR(44 
,IR(45 
10314,12 


1) 
4) 
3) 
2) 
1) 
4) 
3) 
2) 
1) 
•I) 
3) 


4309 


0,12,18,  4309,11318,12 


,3),IR(  9 
,2)  ,  IR  (11 
,1) , IR (13 
,4) , IR (15 
,3) , IR (16 
,2) , IR (18 
,1) ,IR(20 
,4) , IR  (22 
,3) ,IR(23 
,2) ,IR(25 
2,14621, 
,  0,  1251 
,  6,  0 
,  0,  825 
,10,14621 
,13/ 

,3)  ,  IR  (26 
,2)  ,  IR  (28 
,1) ,IR(30 
,4) , IR (32 
,3),IR(33 
,2)  ,  IR  (35 
,1)  ,IR(37 
,4)  ,  IR  (39 
,3)  ,IR(40 
,2) ,IR(42 
,1) ,IR(44 
,4)/ 

,15,  825 
14328 
,18,10348 


IR 

IR 
IR 
IR 
IR 
IR 
IR 
IR 
IR 
IR 
0, 
,10206 
0 

,14580 
,  2916 


,4) 
,3) 
,2) 

,1) 
,4) 
,3) 
,2) 

,1) 
,4) 
,3) 


12 


,4) 
,3) 
,2) 
,1) 
,4) 
,3) 
,2) 
,1) 
,4) 
,3) 
,2) 


IR 
IR 
IR 
IR 
IR 
IR 
IR 
IR 
IR 
IR 
IR 


,14688 
,14580 
,  4309 


10,1) 
11,4) 
13,3) 
15,2) 
17,1) 
18,4) 
20,3) 
22,2) 
24,1) 
25,4) 
,  3, 
12,  5 
0,  0 
12,  8 
12,11 

27,1) 
28,4) 
30,3) 
32,2) 
34,1) 
35,4) 
37,3) 
39,2) 
41,1) 
42,4) 
44,3) 

12,16 
12,17 
12,19 


IR (10 , 2 ) 
IR (12 , 1) 
IR(13,4) 
IR (15  ,3) 
IR(17,2) 
IR(19,1) 
IR(20,4) 
IR  (22 ,3) 
IR(24,2) 


/ 


IR(27,2) 
IR(29,1) 
IR(30,4) 
IR  (32 ,3) 
IR(34,2) 
IR  (36 , 1) 
IR(37,4) 
IR(39,3) 
IR(41,2) 
IR(43,1) 
IR(44,4) 


*LOT  100 
LOT  110 
LOT  120 
LOT  130 
LOT  140 
LOT  150 
LOT  160 
LOT  170 
LOT  180 
LOT  190 
LOT  200 
LOT  210 
LOT  220 
LOT  230 
LOT  240 
LOT  250 
LOT  260 
LOT  270 
LOT  280 
LOT  290 
LOT  300 
LOT  310 
LOT  320 
LOT  330 
LOT  340 
LOT  350 
LOT  360 
LOT  370 
LOT  380 
LOT  390 
LOT  400 
LOT  410 
LOT  420 
LOT  430 
LOT  440 
LOT  450 
LOT  460 
LOT  470 
LOT  480 
LOT  490 
LOT  500 
LOT  510 
LOT  520 
LOT  530 
LOT  540 
LOT  550 
LOT  560 
LOT  570 
LOT  590 
LOT  600 
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c 
c 
c 


c 
c 
c 
c 


c 
c 
c 


c 
c 
c 


c 
c 


F    9160,        0,12,20,  9160,  3645,12,20,  9160,14729,12,21, 
G     1127,  6900,12,22,14108,  5832,12,23,2611,  5832,12,24, 
H  14621,   5832,12,25,   2612,   5832,12,26,  1251,10422,12,27, 
I       825,14067,12,28,  1270,10422,12,29, 
J      825,14796,12,30,     802,  0,12,31/ 
DATA        IR  (46,1)  ,IR (46,2) ,IR (46,3) ,IR  (46,4)  ,IR  (47,1) ,IR (47,2) , 

1  IR  (47,3) ,IR (47,4) ,IR (48,1) ,IR (48,2) ,IR (48,3) ,IR (48,4)/ 

2  802,11280,12,31, 

3  6959,  3839,12,32,  4861,  2736,12,33/ 


GENERA  SET 


FIXED    FLOATI  PLOT 


SPACE  CGS 


DATA 

IR  (50 
IR  (52 
IR  (54 
IR  (55 
IR  (57 
5252 
4713 

8  14284 

9  0 


,3) 
,2) 

,1) 
,4) 
,3) 


IR(49 
, IR (50 
, IR (52 
,IR(54 
, IR (56 
, IR (57 
4132 ,13 
1278,13 
2322,13 
0,  0 


,D 
,4) 
,3) 
,2) 
,1) 
,4) 

,  1 
,  4 
,  9 
,  0/ 


IR(49, 
IR  (51 , 
IR (52 , 
IR (54 , 
IR (56 , 
IR (58 , 
14006, 
12003, 
2395, 


2)  ,IR(49,3) 

1)  , IR (51 ,2) 
4) ,IR(53,1) 

3)  ,IR(54,4) 

2)  ,IR(56,3) 
1) ,IR(58,2) 

0,13,  2 
14580,13,  5 
0,13,10 


IR (49  ,4) 
IR  (51 ,3) 
IR  (53,2) 
IR(55,1) 
IR(56,4) 
IR(58,3) 
4641 
0 

14094 


,  IR (50  ,1) 
,IR(51,4) 
,IR(53,3) 
,IR(55,2) 
,IR(57,1) 
,IR(58,4)/ 
3753,13,  3 
0,   0,  0 
0,13,11 


SI 

IR  (50  ,2) 
IR  (52  , 1 ) 
IR(53,4) 
IR (55  ,3) 
IR (57 ,2) 


BEGIN  SCAN 
IFGT  IFGE 


REPEAT  EXECUT  PERFOR  INCREM  RESTOR  IFLT 
IFNE  IFLE 


DATA  IR (59 , 1 ) 

IR(60,3) ,IR(60,4) 
IR  (62 ,2)  ,  IR  (62  ,3 ) 
IR(64,1) ,IR(64,2) 
IR(65,4) ,IR(66,1) 
IR (67 ,3) ,IR(67,4) 
IR (69 ,2) ,IR(69,3) 
IR(71,1) ,IR(71,2) 


IR (59  , 2 ) 
IR (61 ,1) 
IR(62,4) 
IR(64,3) 
IR (66  ,2) 
IR (68 , 1 ) 
IR(69,4) 


IR(59,3) 
IR(61,2) 
IR(63,1) 
IR(64,4) 
IR(66,3) 
IR(68,2) 
IR(70,1) 
IR(71,4)/ 


IR (59  , 
IR (61 , 
IR (63  , 
IR (65  , 
IR  (66 , 
IR  (68 , 
IR(70, 


IR  (71 ,3) 

1600,6939,14,  1,13933,10206,14,  2,13273, 
4298,  2774,14,  3,11817,  4797,14,  3,  6942, 
13276,15003,14,  8,  6735,14580,14,  9,  6728 
B  6730,14580,14,11,  6730,  3645,14,12,  6737, 
C    6735,  3645,14,14/ 


4)  ,IR(60,1) 

3)  ,IR(61,4) 

2)  ,IR(63,3) 

1)  ,IR(65,2) 

4)  ,IR(67,1) 

3)  ,IR(68,4) 

2)  ,IR(70,3) 

3692,14,  3, 
13270,14,  6, 
,12393,14,10 
3645,14,13, 


IFEQ 


IR (60  ,2 ) 
IR (62  ,1) 
IR(63,4) 
IR (65 ,3) 
IR(67  ,2) 
IR (69 , 1) 
IR(70,4) 


MDEFIN  ADEFIN  AERASE  MZERO    AZERO    MERASE  MIDENT  MSUBTR  MDIAGO 

DATA  IR  (72 , 1) ,IR (72,2) ,IR (72,3) ,IR (72,4) ,IR (73,1) ,IR (73,2) 

1  IR  (73,3) ,IR(73, 4) ,IR (74,1) ,IR (74,2) ,IR (74,3) ,IR (74,4) ,IR (75,1) 

2  IR  (75,2) ,IR (75,3) ,IR (75,4) ,IR (76,1) ,IR (76,2) ,IR (76,3) ,IR (76,4) 

3  IR  (77,1) ,IR(77,2) ,IR (77,3) ,IR (77,4) ,IR (78,1) ,IR(78,2) ,IR (78,3) 

4  IR(78,4) ,IR (79,1) ,IR (79,2) ,IR (79,3) ,IR (79,4) ,IR (80,1) ,IR (80,2) 

5  IR(80,3) ,IR(80,4)/ 

6  9590,4631,15,1,     842,  4631,15,  1,     882,  1247,15,  2, 

7  10184,13527,15,  2,  1436,13527,15,  2,  9630,  1247,15,  2, 

8  9724,  4043,15,  3,10011,  2016,18,  2,  9594,     933,15,  4/ 

MINVER  INVERT  MMULTI 

DATA  IR (81, 1) ,IR (81,2) ,IR (81,3) ,IR (81,4) ,IR (82,1)  ,IR  (82,2)  , 

1  IR(82,3) ,IR (82,4) ,IR (83,1) ,IR (83,2) ,IR (83,3) ,IR (83, 4)/ 

2  9734,16191,16,  1,  6961,  4151,16,  1,  9849,  9297,17,  1/ 

MMULT  MRAISE 


LOT  610 
LOT  620 
LOT  630 
LOT  640 
LOT  650 
LOT  660 
LOT  665 
LOT  670 
LOT  680 
LOT  690 
LOT  700 
LOT  710 
LOT  720 
LOT  730 
LOT  740 
LOT  750 
LOT  760 
LOT  770 
LOT  780 
LOT  790 
LOT  800 
LOT  810 
LOT  820 
LOT  830 
LOT  840 
LOT  850 
LOT  860 
LOT  870 
LOT  880 
LOT  890 
LOT  900 
LOT  910 
LOT  920 
LOT  930 
LOT  940 
LOT  950 
LOT  960 
LOT  970 
LOT  980 
LOT  990 
LOT1000 
L0T1010 
L0T1020 
L0T1030 
L0T1040 
LOT1050 
L0T1060 
L0T1070 
L0T1080 
L0T1090 
L0T1100 
L0T1110 
L0T1120 
L0T1130 
L0T1140 
L0T1150 
L0T1160 
L0T1170 
L0T1180 
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C  LQT1190 
DATA           IR(84,1) ,IR (84,2) ,IR (84,3) ,IR (84,4) ,IR (85,1) ,IR (85,2) ,  L0T1200 

1  IR  (85 ,3) ,IR(85,4)/  L0T1210 

2  9849,  9288,17,  1,  9964,  7079,17,  2/  L0T1220 
C  L0T1230 
C  MADD  MSUB  MTRANS  ATRANS  AADD  ASUB  A MULT  AMULTI  ASUBTR  L0T1240 
C  MSCALA  ADIVIO  ADIV  ARAISE  L0T1250 
C  L0T1260 

DATA  I R  (86,1) ,IR  (86,2) ,IR  (86,3) ,IR  (86,4)  ,IR  (87,1)  ,IR  (87,2) ,  L0T1270 

6  IR(87,3) ,IR  (87,4)  ,IR (88,1)  ,IR  (88,2)  ,IR  (88,3)  ,IR  (88,4) ,  L0T1280 

7  IR  (89 , 1)  ,IR  (89,2) ,IR (89,3) ,IR  (89,4)  ,IR  (90,1)  ,IR  (90,2)  ,IR  (90,3) ,  L0T1290 

8  IR (90,4) ,IR (91,1) ,IR (91,2) ,IR (91,3) ,IR (91,4)  ,IR (92,1)  ,IR (92,2) ,  L0T1300 

9  IR(92,3)  ,IR  (92,4)  ,IR  (93,1) ,IR (93,2)  ,IR (93,3) ,IR (93,4) ,IR (94,1) ,  L0T1310 
A  IR(94,2)  ,IR  (94,3)  ,IR  (94,4)  ,IR  (95,1)  ,IR  (95,2)  ,IR  (95,3)  ,IR  (95,4) ,  L0T1320 
B  IR (96,1) ,IR (96,2) ,IR (96,3) ,IR (96,4)  ,IR (97,1)  ,IR  (97,2)  ,IR  (97,3)  ,  L0T1330 
C  IR(97,4) ,IR(98,1)  ,IR(98,2)  ,IR(98,3)  ,IR(98,4)/  L0T1340 
D  9508,  2916,18,  1,10011,  1458,18,  2,10035,  1126,18,  3,  L0T1350 
E  1287,  1126,18,  3,  760,  2916,18,  4,  1263,  1458,18,  5,  L0T1360 
F  1101,  9288,18,  6,  1101,  9297,18,  6,  1263,  2016,18,  5,  L0T1370 
G  9993,  1054,18,  6,  846,16285,18,  7,  846,16038,18,  7,  L0T1380 
H    1216,  7079,18,  8/  L0T1390 

C  L0T1400 

C  L0T1410 

C  L0T1420 

DATA  IR(  99,1),IR(  99,2),IR(  99,3),IR(  99 ,4 ) , IR ( 100  , 1 )  ,  L0T1430 

1  IR  (100,2) ,IR  (100,3) ,IR  (100,4) ,IR (101,1) ,IR (101,2) ,IR (101,3) ,  L0T1440 

2  IR  (101,4) ,IR  (102,1) ,IR  (102,2) ,IR  (102,3)  ,IR  (102,4) ,IR  (103,1) ,  L0T1450 

3  IR(103,2) ,IR( 103,3) ,IR (103,4 ) ,IR( 104,1) ,IR( 104,2) ,IR(  104,3 )  ,  L0T1460 

4  IR(104,4)/  L0T1470 

5  0,        0,0,0,        0,        0,0,0,        0,        0,0,0,  L0T1480 

6  0,  0,0,0,  0,  0,0,0,  0,  0,0,0/  L0T1490 
C  L0T1500 
C  PARSUM  PARPRO  RMS  AVERAG  SUM  LOT1510 
C  L0T1520 

DATA  IR  (105 , 1 ) ,IR(105,2) ,IR(105,3) ,IR(105,4) ,IR(106,1) ,  L0T1530 

1  IR (106,2) ,IR( 106,3) ,IR (106,4 ) ,IR( 107,1) ,IR (107,2) ,IR  (107,3) ,  L0T1540 

2  IR(107,4) ,IR (108,1) ,IR( 108,2) ,IR( 108,3)  ,IR  (108,4)  ,IR(  109,1)  ,  L0T1550 

3  IR(109,2) ,IR(109,3) ,IR(109,4) /  L0T1560 

4  11709,14431,20,  1,11709,12165,20,  2,13492,        0,20,  3,  L0T1570 

5  1328,13156,20,  4,14431,  0,20,  5/  L0T1580 
C  L0T1590 
C  ROWSUM  PRODUC  DEFINE  MAX  MAXIMU  MIN  MINIMU  SORT  ORDER  L0T1600 
C  ERASE  EXCHAN  FLIP  CHANGE  HIERAR  LIST  NULL  L0T1610 
C  L0T1620 

DATA  IR(110,1) ,IR(110,2) ,IR(110,3) ,IR(110,4)  ,IR(111,1)  ,  LOT1630 

1  IR (111,2) ,IR (111,3) ,IR (111,4) ,IR (112,1) ,IR (112,2) ,IR  (112,3) ,  L0T1640 

2  IR(112,4) ,IR (113,1) ,IR( 113,2) ,IR( 113,3) ,IR( 113,4 ) ,IR  (114,1 ) ,  L0T1650 

3  IR (114,2) ,IR( 114,3) ,IR( 114,4 ) ,IR (115,1) ,IR( 115,2)  ,IR(  115,3)  ,  LOT1660 

4  IR (115,4) ,IR (116,1 ) ,IR (116,2 ) ,IR (116,3 ) ,IR  (116,4)  ,IR  (117,1)  ,  L0T1670 

5  IR (117,2) ,IR (117,3) ,IR(117,4) ,IR (118,1) ,IR (118,2) ,IR  (118,3) ,  L0T1680 

6  IR(118,4) ,IR (119,1) ,IR( 119,2) ,IR( 119,3) ,IR( 119,4 )  ,IR(  120,1)  ,  L0T1690 

7  IR (120,2) ,IR (120,3) ,IR (120,4) ,IR (121,1) ,IR (121,2) ,IR (121,3) ,  L0T1700 

8  IR (121,4) ,IR (122,1) ,IR (122,2) ,IR (122,3) ,IR  (122,4)  ,IR  (123,1)  ,  L0T1710 

9  IR (123,2 ) ,IR (123,3) ,IR (123,4) ,IR (124,1) ,IR (124,2) ,IR (124,3)  ,  L0T1720 
A  IR (124,4) ,IR (125,1) ,IR( 125,2) ,IR( 125,3 ) ,IR( 125,4 ) ,IR (126,1) ,  L0T1730 
B  IR  (126 ,2) ,IR(126,3) , IR  (126 ,4) /  L0T1740 
C  13550,14431,21,  1,12165,  3486,21,  2,  3057,  6944,21,  3,  L0T1750 
D  9528,  0,21,  5,  9528,  6933,21,  5,  9734,  0,21,  6,  LOT1760 
E    9734,  6933,21,  6,14274,14580,21,  8,11425,  4131,21,  9,  L0T1770 
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F    4132,13986,21,10,  4296,  5873,21,11,  4707,11664,21,12,  LOT1780 

G     2404,10400,21,13,  6080,13167,21,14,  9010,14580,21,15,  L0T1790 

H          0,        0,  0,  0,10785,  8748,21,17/  L0T1800 

C  L0T1810 

C         POLYFI  SPOLYF  FIT        SFIT      SOLVE    MORTHO  L0T1820 

C  L0T1830 

DATA             IR (127 , 1 ) ,IR(127,2) ,IR(127,3) ,IR(127,4)  ,IR(128,1)  ,  L0T1840 

1  IR  (128,2) ,IR (128,3) ,IR (128,4) ,IR (129,1) ,IR (129,2) ,IR (129,3 ) ,  L0T1850 

2  IR  (129,4) ,IR (130,1) ,IR  (130,2) ,IR (130,3) ,IR  (130,4)  ,IR  (131,1)  ,  L0T1860 

3  IR  (131,2) ,IR (131,3 ) ,IR (131,4) ,IR (132,1) ,IR (132,2) ,IR (132,3) ,  L0T1870 

4  IR(132,4)/  L0T1880 

5  12081,18396,22,  1,14298,  9429,22,  2,  4637,        0,22,  3,  LOT1890 

6  14022,14580,22,  4,14268,16173,16,  2,  9900,14811,22,  5/  LOT1900 
C  L0T1910 
C  COUNT  SHORTE  EXPAND  DUPLIC  MOVE  DIM  AMOVE  L0T1920 
C  MMOVE  PROMOT  DEMOTE  DIMENS  L0T1930 
C  L0T1940 

DATA             IR  (133 , 1) ,IR(133,2) ,IR(133,3) ,IR(133,4)  ,IR(134,1)  ,  L0T1950 

1  IR  (134,2) ,IR (134,3) ,IR (134,4) ,IR (135,1) ,IR (135,2 )  ,IR  (135,3 ) ,  L0T1960 

2  IR (135,4) ,IR (136,1) ,IR (136,2) ,IR (136,3) ,IR (136,4)  ,IR  (137,1)  ,  LOT1970 

3  IR(137,2) ,IR(137,3) , IR  (137 , 4 ) , IR (138 , 1 ) , IR ( 138  , 2 ) , IR  ( 138 , 3 ) ,  L0T1980 

4  IR (138,4) ,IR (139,1) ,IR (139,2) ,IR (139,3) ,IR  (139,4) ,IR  (140,1)  ,  L0T1990 

5  IR  (140,2) ,IR (140,3) ,IR (140,4) ,IR (141,1) ,IR (141,2) ,IR (141,3) ,  L0T2000 

6  IR (141,4) ,IR (142,1) ,IR (142,2) ,IR (142,3) ,IR  (142,4)  ,IR  (143,1)  ,  L0T2010 

7  IR(143,2) ,IR(143,3) ,IR(143,4) , IR ( 144 , 1 ) , IR  (144 , 2 ) , IR  (144 , 3 ) ,  L0T2020 

8  IR(144,4) ,IR(145,1) ,IR(145,2)  ,IR(145,3)  ,IR(145,4)  /  L0T2030 

9  0,  0,  0,  0,  0,  0,  0,  0,  2613,10746,23,  2,  L0T2040 
A  14082,13667,23,  3,  4309,  1111,23,  4,  3499,  8994,23,  5,  L0T2050 
B  9904,  3645,23,  6,  3172,  0,23,12,  1095,16173,23,  6,  L0T2060 
C  9843,16173,23,  6,12165,  9902,23,10,  3064,11480,23,11,  L0T2070 
D    3172,  4042,23,12/  L0T2080 

C  L0T2090 

C         STATIS    SSTATI  RANKS    ACCURA  L0T2100 

C  L0T2110 

DATA             IR(146,1) ,IR(146,2) ,IR(146,3)  ,IR(146,4) ,IR(147,1)  ,  L0T2120 

1  IR (147,2) ,IR (147,3 ) ,IR (147,4) ,IR (148,1) ,IR (148,2) ,IR  (148,3) ,  L0T2130 

2  IR  (148,4) ,IR (149,1) ,IR  (149,2) ,IR( 149,3) ,IR (149,4 ) ,IR (150,1 ) ,  L0T2140 

3  IR(150,2) ,IR(150,3) ,IR(150,4) /  L0T2150 

4  14392,14842,24,  1,14384,  1278,24,  2,13163,  8532,24,  3,  L0T2160 

5  813,15796,11,  6,  0,  0,  0,  0/  L0T2170 
C  L0T2180 
C  SELECT  SEARCH  CENSOR  L0T2190 
C  L0T2200 

DATA             IR (151 ,1) ,IR(151,2) ,IR(151,3) ,IR(151,4)  ,IR(152,1)  ,  L0T2210 

1  IR (152,2) ,IR (152,3) ,IR (152,4) ,IR (153,1) ,IR (153,2) ,IR (153,3)  ,  L0T2220 

2  IR(153,4)/  L0T2230 

3  13998,  3746,25,  1,13987,13211,25,  2,  2336,14274,25,  3/  L0T2240 
C  L0T2250 
C  MVECDI  MVECMA  MMATV  L0T2260 
C  L0T2270 

DATA             IR(154,1) ,IR(154,2) ,IR(154,3) ,IR(154,4) ,IR(155,1) ,  L0T2280 

1  IR (155,2) ,IR (155,3) ,IR (155,4) ,IR (156,1) ,IR (156,2) ,IR  (156,3) ,  LOT2290 

2  IR (156,4) ,IR (157,1) ,IR (157,2) ,IR (157,3) ,IR (157,4) ,IR (158,1) ,  L0T2300 

3  IR (158,2 ) ,IR (158,3 ) ,IR (158,4) ,IR (159,1) ,IR (159,2) ,IR (159,3) ,  L0T2310 

4  IR(159,4)/  L0T2320 

5  10076,  2304,26,  1,        0,        0,  0,  0,10076,  2539,26,  2,  L0T2330 

6  0,  0,  0,  0,  9829,15179,26,  3,  0,  0,  0,  0/  L0T2340 
C  L0T2350 
C         MKRONE  MTRIAN  MEIGEN  L0T2360 
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C  L0T2370 

DATA  IR  (160 , 1 ) ,IR(160,2) , IR (160 ,3 )  ,  IR (160 ,4 ) ,IR(161,1) ,  LOT2380 

1  IR  (l&l ,2) ,IR (161,3) ,IR  (161,4) ,IR  (162,1)  ,IR  (162,2)  ,IR  (162,3)  ,  L0T2390 

2  IR(162,4)/  L0T2400 

3  9792,11318,17,  3,10035,  6602,17,  4,  9621,  5252,17,  5/  L0T2410 
C  L0T2420 
C  INTERP  L0T2430 
C  L0T2440 

DATA  IR(163,1) ,IR(163,2) ,IR(163,3) ,IR(163,4)  /  L0T2450 

1     6959,  4147,25,  4/  L0T2460 

C  L0T2470 

C         MPROPE  APROPE  SMPROP  SAPROP  L0T2480 

DATA  IR(164,1) ,IR(164,2) ,IR(164,3)  ,IR(164,4)  ,  IR  ( 165  , 1 ) ,  L0T2490 

1  IR  ( 165,2) ,IR(  165,3) ,IR (165,4) ,IR (166,1) ,IR (166,2) ,IR (166,3) ,  L0T2500 

2  IR(166,4) ,IR(167,1) ,IR(167,2) ,IR(167,3)  ,IR(167,4)/  LOT2510 

3  9927,11372,27,  1,   1179,11372,27,   2,  L0T2520 

4  14218,13543,27,  3,13894,13543,27,  4/  L0T2530 
C  L0T2540 
C  ITERATE  ISETUP  ISOLATE  L0T2550 
C  L0T2560 

DATA  IR(168,1)  ,IR(168,2) ,IR(168,3)  ,IR(168,4) ,IR(169,1) ,  L0T2570 

1  IR (169,2) ,IR (169,3 ) ,IR (169,4) ,IR  (170,1) ,IR  (170,2)  ,IR  (170,3 ) ,  L0T2580 

2  IR(170,4)/  L0T2590 

3  7106,13169,28,  1,  7079,15163,28,  2,  7089,  8795,28,  3/  L0T2600 
C  L0T2610 
C  EXTREMA  SEPARATE  INSERT  MAXMIN  L0T2620 
C  L0T2630 

DATA  IR (171 , 1 ) ,IR(171,2) , IR (171 ,3 ) ,IR(171,4) f IR  (172  , 1)  ,  L0T2640 

1  IR (172,2) ,IR (172,3 ) ,IR (172,4) ,IR (173,1) ,IR  (173,2)  ,IR  (173,3 )  ,  L0T2650 

2  IR(173,4) ,IR(174,1) ,IR(174,2) ,IR(174,3) ,IR(174,4)/  L0T2660 

3  4313,13270,29,  4,14002,   1216,29,  2,  6958,  4151,29,  3,  L0T2670 

4  9528,  9734,29,  4/  L0T2680 
C  LOT2690 
C  LAGUER  NORMLA  HERMIT  UCHEBY  TCHEBY  LEGEND  LOT2700 
C  L0T2710 

DATA  IR  (175 , 1) ,IR(175,2) , IR (175 ,3 ) ,IR(175,4) ,IR(176,1) ,  L0T2720 

1  IR  (176,2) ,IR  (176,3 ) ,IR  (176,4) ,IR  (177,1) ,IR  (177,2) ,IR (177,3) ,  L0T2730 

2  IR  (177,4)  ,IR  (178,1) ,IR  (178,2) ,IR (178,3) ,IR (178,4) ,IR (179,1) ,  L0T2740 

3  IR  (179,2)  ,IR  (179,3)  ,IR  (179,4) , IR (180,1) ,IR (180,2 ) ,IR (180,3) ,  L0T2750 

4  IR(180,4)/  L0T2760 

5  8782,15462,19,  2,10629,  9802,19,  1,  5985,  9740,19,  3,  L0T2770 

6  15398,  3724,19,  4,14669,  3724,19,  6,  8890,  4027,19,  5/  L0T2780 
C  L0T2790 
C  BJZERO  BJONE  BYZERO  BYONE  BIZERO  BIONE  BKZERO  BKONE  L0T2800 
C  EXIZER  EXIONE  EXKZER  EXKONE  KBIZER  KBIONE  KBKZER  KBKONE  L0T2810 
C  L0T2820 

DATA  IR(181,1) ,IR(181,2)  ,IR(181,3) ,IR(181,4) ,IR(182,1) ,  L0T2830 

1  IR  (182,2 ) ,IR (182,3) ,IR (182,4) ,IR (183,1) ,IR (183,2 ) ,IR (183,3) ,  L0T2840 

2  IR (183,4) ,IR (184,1) ,IR (184,2) ,IR (184,3) ,IR (184,4) ,IR (185,1) ,  L0T2850 

3  IR (185,2) ,IR (185,3) ,IR  (185,4) ,IR  (186,1)  ,IR  (186,2) ,IR (186,3 ) ,  L0T2860 

4  IR  (186  ,4) ,IR  (187,1) ,IR  (187,2 )  ,IR (187,3 )  ,IR  (187,4) ,IR (188,1) ,  L0T2870 

5  IR  (188,2) ,IR (188,3) ,IR (188,4) ,IR (189,1)  ,IR  (189,2) ,IR (189,3) ,  L0T2880 

6  IR(189,4) ,IR( 190,1) ,IR(  190,2 ) ,IR(  190,3)  ,IR(  190,4 )  ,IR(  191,1)  ,  L0T2890 

7  IR  (191,2 )  ,IR  (191,3)  ,IR  (191,4) ,IR  (192,1)  ,IR  (192,2 )  ,IR  (192,3) ,  L0T2900 

8  IR  (192,4) ,IR (193,1) ,IR (193,2) ,IR  (193,3 )  ,IR  (193,4) ,IR (194,1)  ,  L0T2910 

9  IR(194,2) ,IR (194,3) ,IR (194,4) ,IR (195,1) ,IR(  195,2)  ,IR(  195,3)  ,  L0T2920 
A  IR(195,4) ,IR(196,1) ,IR(196,2) ,IR(196,3) ,IR(196,4) /  L0T2930 
B  1754,  4146,30,  1,  1743,10341,30,  2,  2159,  4146,30,  3,  L0T2940 
C     2148,10341,30,  4,  1727,  4146,30,  5,  1716,10341,30,  6,  L0T2950 
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D     1781,  4146,30,  7,   1770,10341,30,  8,  4302,19107,30,  9,  L0T2960 

E    4302,11318,30,10,  4304,19107,30,11,  4304,11318,30,12,  LOT2970 

F     8082,19107,30,13,  8082,11318,30,14,  8084,19107,30,15,  L0T2980 

G     8084,11318,30,16/  L0T2990 

C  L0T3000 

C         KEXIZE  KEXION  KEXKZE  KEXKON  CIZERO  CIONE  CKZERO  CKONE  L0T3010 

C         CEIZER  CEIONE  CEKZER  CEKONE  INTJO    BESJN    HARMON  BESIN  L0T3020 

C         BESKN  L0T3030 

C  L0T3040 

DATA  IR(197,1) ,IR(197,2) ,IR(197,3) ,IR(197,4) ,IR(198,1) ,  L0T3050 

1  IR  (198,2) ,IR (198,3) ,IR(198,4) ,IR (199,1) ,IR (199,2) ,IR (199,3) ,  L0T3060 

2  IR  (199,4) ,IR (200,1) ,IR (200,2) ,IR (200,3  ) ,IR (200,4) ,IR (201,1) ,  L0T3070 

3  IR  (201,2) ,IR (201,3) ,IR (201,4) ,IR (202,1  ) ,IR( 202,2 ) ,IR (202,3) ,  L0T3080 

4  IR  (202,4 ) ,IR (203,1) ,IR (203,2) ,IR (203,3) ,IR(203, 4) ,IR (204,1) ,  L0T3090 

5  IR  (204,2) ,IR (204,3) ,IR (204,4) ,IR (205,1) ,IR (205,2) ,IR (205,3) ,  L0T3100 

6  IR  (205,4) ,IR (206,1) ,IR (206,2) ,IR (206,3 ) ,IR (206,4) (IR (207,1) ,  L0T3110 

7  IR  (207,2 )  ,IR  (207,3 ) ,IR (207,4) ,IR (208,1) ,IR (208,2) ,IR (208,3 ) ,  L0T3120 

8  IR  (208,4) ,IR  (209,1) ,IR (209,2 ) ,IR (209,3 ) ,IR (209,4) ,IR (210,1) ,  L0T3130 

9  IR  (210 ,2) ,IR (210,3) ,IR (210,4) ,IR (211,1) fIR (211,2) ,IR (211,3) ,  L0T3140 
A  IR(211,4),IR(212,l),IR(212f2),IR(212,3),IR(212,4),IR(213,l),  L0T3150 
B  IR(213,2) , IR  (213 ,3 ) ,IR(213,4)/  L0T3160 
C  8178,  7268,30,17,  8178,  6980,30,18,  8178,  8726,30,19,  L0T3170 
D  8178,  8438,30,20,  2456,  4146,30,21,  2445,10341,30,22,  L0T3180 
E  2510,  4146,30,23,  2499,10341,30,24,  2331,19107,30,25,  L0T3190 
F  2331,11318,30,26,  2333,19107,30,27,  2333,11318,30,28,  L0T3200 
G  6959,  7695,30,29,  1612,  7668,30,32,  5877,  9896,30,37,  L0T3210 
H     1612,  6939,30,38,  1612,  8397,30,39/  L0T3220 

C  L0T3230 

C         TWOWAY  L0T3240 

C  L0T3250 

DATA  IR(214,1) ,IR(214,2) ,IR(214,3) ,IR(214,4) /  L0T3260 

1  15216,16819,24,6/  L0T3270 

C  L0T3280 

C         FLEXIB  L0T3290 

C  L0T3300 

DATA  IR (215 , 1 ) , IR (215 ,2 ) , IR (215 ,3) ,IR(215,4)/  L0T3310 

1     4703,17741,13,12/  L0T3320 

C  LOT3330 

C         SQUARE  L0T3340 

C  L0T3350 

DATA  IR(216,1) , IR (216 ,2) ,IR(216,3) ,IR(216,4) /  L0T3360 

1  14331,  1220,12,34/  L0T3370 

C  L0T3380 

C         ACOALE  AAVERA  L0T3390 

C  L0T3400 

DATA  IR (217 , 1 ) , IR (217 , 2 ) , IR (217 ,3 ) ,IR(217,4) , IR  (218  , 1 )  ,  L0T3410 

1  IR  (218  ,2) ,IR(218,3) ,IR(218,4)/  L0T3420 

2  825,  1058,18,  9,  778,  4132,18,10/  L0T3430 
C  L0T3440 
C  MATCH  L0T3450 
C  L0T3460 

DATA  IR (219 ,1) , IR (219 ,2) , IR (219 ,3 ) ,IR(219,4)/  L0T3470 

1  9524,2403,25,5/  LOT3480 

C  L0T3490 

C         HISTOG  NHISTO  FREQUE  L0T3500 

C  L0T3510 

DATA  IR  (220,1) ,IR (220,2) ,IR (220,3 ) ,IR (220,4) ,IR (221,1) ,  L0T3520 

1  IR  (221 ,2) , IR (221 ,3 ) , IR (221 , 4 ) , IR ( 222 , 1 ) , IR (222  , 2 ) , IR (222 , 3 ) ,  L0T3530 

2  IR  (222 ,4) /  L0T3540 
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3     6094,14992,24,  8,10431,14406,24,  9,  4865,12965,24,10/  L0T3550 

C  LOT3560 

C         CORREL  SCORRE  L0T3570 

C  L0T3580 

DATA         IR(223,1) ,IR(223,2) , IR (223 ,3 ) ,IR(223,4)  ,IR(224,1)  ,  L0T3590 

1  IR(224,2) ,IR(224,3) ,IR(224,4)/  L0T3600 

2  2610,13269,24,11,13947,13613,24,12/  L0T3610 
C  L0T3620 
C  COMPARE, ONEWAY, SONEWAY , ERROR, CERF,STWOWAY  L0T3630 
C  L0T3640 


DATA  IR (225,1) ,IR (225,2) ,IR (225,3) ,IR (225,4) ,IR (226,1) ,IR (226,2) ,  L0T3650 

1  IR (226,3) ,IR (226,4) ,IR (227,1) ,IR  (227,2 )  ,IR  (227,3)  ,IR  (227,4)  ,  L0T3660 

2  IR  (228,1)  ,IR  (228,2)  ,IR  (228,3 )  ,  IR  (228,4)  ,IR  (229,1) ,IR (229,2) ,  L0T3670 

3  IR (229,3 ) ,IR  (229,4) ,IR (230,1)  ,IR(230,2)  ,  IR  (230  ,3 )  ,  IR  (230,4 ) /  L0T3680 

4  2605,11709,14,15,11318,16819,24,13,14270,  4267,24,14,  L0T3690 

5  4149,11421,21,18,  2340,  4374,21,19,14414,11557,24,  7/  L0T3700 
C  L0T3710 
C         CTOF,FTOC, ATOMIC, MOLWT, EINSTEIN, PFTRANS ,PFATOMIC ,PARTFUNCT ,B0LDISTL0T3720 

DATA     IR (231, 1) ,IR (231,2) ,IR (231,3 ) ,IR (231,4) , IR  (232 , 1)  ,IR(232,2) ,L0T3730 

1  IR (232  ,3 ) ,IR(232,4) ,IR  (233,1)  ,  IR  (233 , 2 )  ,  IR (233 , 3 ) ,IR(233,4) ,L0T3740 

2  IR (234,1) ,IR(234,2) ,IR (234,3) , IR (234 , 4 )  ,  IR (235 , 1 ) , IR (235 ,2) ,L0T3750 

3  IR (235  ,3 )  ,IR(235,4) , IR (236 , 1 )  ,  IR (236 , 2 )  ,  IR (236 , 3 ) , IR (236 , 4 ) ,L0T3760 

4  IR (237, 1) ,IR  (237,2) ,IR  (237,3)  ,IR  (237,4)  ,IR  (238,1)  ,IR  (238, 2) ,L0T3770 

5  IR(238,3) ,IR(238,4) , IR (239,1) ,IR(239,2)  ,IR(239,3)  ,  IR  (239  ,4 ) /L0T3780 

6  2742,  4374,31,  1,  4929,  2187,31,  2,  1284,  9723,31,  3,  9894 , 17307L0T3790 

7  ,31,  4,  3902,14396,31,5,11846,13163,31,  6,11827,14998,31,  7 , 11709L0T3800 


8   ,14763,31,  8,  1875,  3178,31,  9/  L0T3810 

C  L0T3820 

C         ROUND  L0T3830 

C  L0T3840 
DATA  IR (240,1) ,IR(240,2) , IR (240 , 3 ) , IR (240 , 4 ) / 13548 , 10314 , 13  , 14/  L0T3850 

C  L0T3860 

C         COMPLEX  ARITHMETIC  -  CADD,  CSUBTRACT,  CMULTIPLY ,  CDIVIDE,  L0T3870 

C  CRECTANGULAR,  CPOLAR  L0T3880 

C  L0T3890 


DATA  IR (241,1) ,IR(241,2) ,IR(241,3) ,IR(241,4)  ,IR  (242,1)  ,IR(242,2)  ,L0T3900 

1  IR(242,3)  ,IR(242,4)  ,IR  (243,1)  ,  IR  (243  , 2 )  ,  IR  (243  , 3 )  ,IR(243,4)  ,L0T3910 

2  IR (244,1) ,IR(244,2) ,IR(244,3) , IR (244  ,4 ) , IR (245 , 1 )  ,  IR  (245  , 2 )  ,L0T3920 

3  IR(245,3) ,IR(245,4) ,IR  (246,1) ,IR(246,2)  ,IR(246,3) , IR (246 ,4) /L0T3930 


4  2218,  2916,32,  1,  2721,  2016,32,  2,  2559,  9297,32,  3,  L0T3940 

5  2304,16285,32,  4,  2678,  2728,32,  5,  2634,  8793,32,  6/  L0T3950 

C  L0T3960 

q        **** *  **********************  ************* *************** **»*********|^Qj2 9 7Q 

C  *  *L0T3980 
C  *  USED  THUR  IR (246,4) : AVAILABLE  IR(247,1)  THRU  IR(300,4)  *LOT3990 
C        *  *L0T4000 

q  ********************************************************  ***********|_q-|-4q^q 

C  L0T4020 

C         RESET    PRINT    PUNCH    READ      ABRIDG  APRINT  MPRINT  L0T4030 

C  L0T4040 

DATA         ID (1, 1) , ID (1,2) , ID (1,3) , ID (2,1) , ID (2,2)  ,  ID  (2,3)  ,  ID  (3,1)  ,  L0T4050 

1  ID (3,2), ID (3,3), ID (4,1) , ID (4,2) , ID (4,3) , ID  (5,1)  ,  ID  (5,2)  ,  ID  (5,3)  ,  L0T4060 

2  ID(6,1),ID(6,2),ID(6,3),ID(7,1),ID(7,2),ID(7,3)/  L0T4070 

3  13276,  4185,1,12159,10746,2,12245,  2403,3,13258,  2916,5,  L0T4080 

4  801,  6676,6,  1179,  6959,4,  9927,  6959,7/  L0T4090 
C  LOT4100 
C  NPRINT  L0T4110 
C  L0T4120 

DATA  ID (8 ,1) , ID (8 ,2) , ID (8 ,3)  /  LOT4130 
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1  10656,  6959,8/  L0T4140 

C  L0T4150 

C         A  B  C  D  E  F  L0T4160 

C  L0T4170 

DATA         IALPH(l) ,IALPH(2) ,IALPH(3) ,IALPH(4) ,IALPH(5) ,IALPH(6)/  L0T4180 

1      729,  1458,  2187,  2916,  3645,  4374/  L0T4190 

C  L0T4200 

C         V  W  X  Y  Z  L0T4210 

C  L0T4220 

DATA         NALPH (1 ) ,NALPH (2 ) ,NALPH (3 ) ,NALPH (4 )  ,NALPH  (5  )  /  L0T4230 

1  16038,16767,17496,18225,18954/  L0T4240 

C  L0T4250 

C         NO  LIST    CLOSE  UP    NEW  PAGE  LOT4260 

C         M(XX/)  M(X/AX)=M(X/X)  M(XAX/)  M(AD)  M(DA)  M(AV)  M(V/A)  L0T4270 

C  L0T4280 

DATA  IRD (  1,1),IRD(  1,2),IRD(  1,3),  IRD  (  1,4),IRD(  1,5),  L0T4290 

1  IRD (  1,6) , IRD (  2,1) , IRD (  2,2), IRD  (  2,3) , IRD  (  2,4),IRD(  2,5),  L0T4300 

2  IRD (  2,6),IRD(  3,1) , IRD  (  3,2)  ,IRD(  3,3),IRD(  3,4),IRD(  3,5),  L0T4310 

3  IRD (  3,6),IRD(  4,1),IRD(  4,2),IRD(  4,3),IRD(  4,4),IRD(  4,5),  L0T4320 

4  IRD (  4,6),IRD(  5,1),IRD(  5,2),IRD(  5,3),IRD(  5,4),IRD(  5,5),  L0T4330 

5  IRD {  5,6),IRD(  6,1),IRD(  6,2),IRD(  6,3),IRD(  6,4),IRD(  6,5),  L0T4340 

6  IRD (  6,6),IRD(  7,1), IRD (  7,2) , IRD (  7,3),IRD(  7,4),IRD(  7,5),  L0T4350 

7  IRD {  7,6),IRD(  8,1),IRD(  8,2),IRD(  8,3),IRD(  8,4),IRD(  8,5),  L0T4360 

8  IRD  (  8,6),IRD(  9,1),IRD(  9,2),IRD(  9,3),IRD(  9,4),IRD(  9,5),  L0T4370 

9  IRD {  9,6) ,IRD(10,1) ,IRD(10,2) ,IRD(10,3) ,IRD(10,4) ,IRD(10,5) ,  L0T4380 
A  IRD(10,6)/  L0T4390 
B  10611,  0,  9010,14580,21,16,  2526,13986,15741,  0,23,  1,  L0T4400 
C  10364,  0,11698,  3645,13,  8,  9477,  0,18144,  0,51,  1,  L0T4410 
D  9477,  0,17496,  0,51,  2,  9477,  0,17547,  0,51,  3,  LOT4420 
E  9477,  0,  837,  0,52,  1,  9477,  0,2943,  0,52,  2,  LOT4430 
F    9477,        0,  1323,        0,53,  1,  9477,        0,16038,        0,53,  2/  L0T4440 

C  L0T4450 

C         DUMMY      A  B  C  D  L0T4460 

C  L0T4470 

DATA  IRD(11,1) , IRD (11 ,2) ,IRD(11,3) ,IRD(11,4) ,IRD(11,5) ,  LOT4480 

1  IRD  (11,6) , IRD (12,1) , IRD (12,2) , IRD (12,3) , IRD (12,4) , IRD (12,5) ,  L0T4490 

3  IRD (12,6) , IRD (13,1) , IRD (13,2) , IRD (13,3) , IRD (13,4)  ,  IRD  (13,5)  ,  LOT4500 

3  IRD (13,6) , IRD (14,1) , IRD (14,2) , IRD (14,3) , IRD (14,4) , IRD (14,5)  ,  L0T4510 

4  IRD  (14,6) , IRD (15,1) , IRD (15,2) , IRD (15,3) , IRD (15,4) , IRD (15,5) ,  L0T4520 

5  IRD(15,6)/  L0T4530 

6  0,        0,        0,        0,  0,  0,  3496,10152,     729,        0,54,  2,  L0T4540 

7  3496,10152,  1458,        0,54,  3,  3496,10152,2187,        0,54,  4,  L0T4550 

8  3496,10152,  2916,  0,54,  5/  L0T4560 
C  L0T4570 
C  ROW  SUM  F  PROBAB  L0T4580 
C  L0T4590 

DATA  IRD(16,1) ,IRD(16,2) ,IRD(16,3) ,IRD(16,4) ,IRD(16,5) ,  L0T4600 

1  IRD  (16,6) , IRD  (17,1) , IRD (17,2) , IRD (17,3) , IRD  (17,4) , IRD  (17,5) ,  L0T4610 

2  IRD(17,6)/  L0T4620 

3  13550,  0,14431,  0,21,1,  4374,  0,12165,  1487,24,5/  L0T4630 
C  L0T4640 
C  ELLIPT  FIRST  ELLIPT  SECOND  ZEROS  BJZERO  ZEROS  BJONE  L0T4650 
C  STRUVE  ZERO  STRUVE  ONE  L0T4660 
C  LOT4670 

DATA  IRD (18 ,1) ,IRD(18,2) ,IRD(18,3) ,IRD(18,4) ,IRD(18,5)  ,  LOT4680 

1  IRD  (18,6) , IRD (19,1) , IRD (19,2) , IRD (19,3) , IRD (19,4) , IRD (19,5) ,  LOT4690 

2  IRD  (19,6 ) , IRD (20,1) , IRD (20,2) , IRD (20,3) , IRD (20,4) , IRD (20,5) ,  L0T4700 

3  IRD  (20,6) , IRD (21,1) , IRD (21,2) , IRD (21,3) , IRD (21,4) , IRD (21,5) ,  L0T4710 

4  IRD  (21, 6) , IRD (22,1) , IRD (22,2) , IRD (22,3) , IRD (22,4) , IRD (22, 5) ,  L0T4720 
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5  IRD  (22,6) (IRD (23,1) ,IRD (23,2) ,IRD  (23,3) , IRD  (23,4)  ,IRD  (23,5)  ,  L0T4730 

6  IRD  (23  ,6)  /  L0T4740 

7  3981,  7013,  4635,14391,30,30,  3981,  7013,13989,11317,30,31,  L0T4750 

8  19107,11448,   1754,  4146,30,33,19107,11448,   1743,10341,30,34,  L0T4760 

9  14409,15908,19107,10935,30,35,14409,15908,11318,  0,30,36/  L0T4770 
C  L0T4780 
C  L0T4790 
C  LOT4800 

DATA               IRD (24  , 1 ) ,  IRD (24 , 2 ) ,IRD(24,3) ,IRD(24,4) ,IRD(24,5)  ,  L0T4810 

1  IRD(24,6)/  L0T4820 

2  0,  0,  0,  0,  0,  0/  L0T4830 
C  LOT4840 
C  PAGE  PLOT  L0T4850 
C  L0T4860 

DATA               IRD (25 , 1 ) , IRD (25 , 2 ) , IRD  (25 ,3) ,IRD(25,4) ,IRD(25,5) ,  L0T4870 

1  IRD(25,6)/  L0T4880 

2  11698,  3645,12003,14580,13,  6/  L0T4890 
C  LOT4900 
C  GAUSS  QUADRATURE  L0T4910 
C  L0T4920 

DATA             IRD(26,1) ,IRD(26,2) ,IRD(26,3) ,IRD(26,4)  ,IRD(26,5)  ,  LOT4930 

1  IRD(26,6)/  L0T4940 

2  5151,14364,12961,  3403,24,  4/  L0T4950 
C  LOT4960 
C  DUMMY  E  F  UNIFOR  RANDOM  L0T4970 
C  L0T4980 

DATA             IRD(27,1)  ,IRD(27,2) ,IRD(27,3) ,IRD(27,4) ,IRD(27,5) ,  L0T4990 

1  IRD (27,6 ), IRD (28,1) , IRD  (28,2) , IRD  (28,3)  ,  IRD  (28,4) , IRD  (28,5) ,  L0T5000 

2  IRD (28, 6) , IRD (29,1) , IRD (29, 2) , IRD (29,3) , IRD  (29,4) , IRD  (29,5) ,  L0T5010 

3  IRD(29,6)/  3496,10152,  3645,        0,54,  6,  3496,10152,  4374,        0,  L0T5015 

4  54,  7,15696,  4797,13163,  3334,24,15/  L0T5020 
C  L0T5030 

Q  **********************  *********************  ******************  ******|^Q-|-£Q^Q 

C        *  *L0T5050 

C        *  USED  THRU  IRD(29,6):  AVAILABLE  IRD(30,1)  THRU  IRD(30,6)  *L0T5060 

C        *  *L0T5070 

Q  *******************************************************************^QJ(JQgQ 

c****  THE  FOLLOWING  CARD  IS      NEEDED  ONLY  FOR  TAPE  OPERATIONS  LOT5090 

C  LOT5100 
C         READ  TAPE ,CREAD  TAPE, WRITE  TAPE , SETTAPE ,CSET  TAPE ,ENDFILE  TAPE,  L0T5110 

C         REWIND  TAPE,  SKIP  TAPE , BACKSPACE  TAPE  L0T5120 

C  L0T5130 

DATA             ITP(1,1) ,ITP(1,2) ,ITP(1,3) ,ITP(1,4) ,ITP(2,1) ,  L0T5140 

1  ITP(2,2) ,ITP(2,3) ,ITP(2,4) ,ITP(3,1) ,ITP(3,2) ,ITP(3,3)  ,  L0T5150 

2  ITP(3,4) ,ITP(4,1) ,ITP(4,2) ,ITP(4,3) ,ITP(4,4)  ,ITP(5,1)  ,  L0T5160 

3  ITP(5,2) ,ITP(5,3) ,ITP(5,4) ,ITP(6,1) ,ITP(6,2) ,ITP(6,3)  ,  L0T5170 

4  ITP(6,4) ,ITP(7,1) ,ITP(7,2) ,ITP(7,3) ,ITP(7,4) ,ITP(8,1) ,  L0T5180 

5  ITP(8,2) ,ITP(8,3) ,ITP(8,4) ,ITP(9,1)  ,ITP(9,2)  ,ITP(9,3)  ,  LOT5190 

6  ITP(9,4)/  LOT5200 

7  13258,  2916,45,1,  2678,     837,46,1,17262,14715,47,1,  LOT5210 

8  14006,        0,48,1,  2705,14580,49,1,  4027,  4629,50,1,  L0T5220 

9  13280,  6943,50,2,14157,11664,50,3,  1488,  8548,50,4/  L0T5230 
£***********************************************************************I_qj5240 

C  L0T5250 
q*********************************************************************  *  *  LOT  5  260 

q***********************************************************************I_qj^270 

C  *****  USED  THRU  ITP(9,4):  AVAILABLE  ITP(10,1)  THRU  ITP (10 ,4 ) ********L0T5280 
£***********************************************************************LQj5290 

Q***********************************************************************|_QJ^3QQ 

END  L0T5310 
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SUBROUTINE  LOOKUP  LOU  10 

C         VERSION    5.00          LOOKUP          5/15/70  LOU  20 

C         WRITTEN  BY  S  PEAVY        3/14/68  LOU  30 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG  LOU  40 

COMMON  /ICODE/  NIR,NID,NIRD,LIR,LIO,LIRD  LOU  50 

COMMON  /CODE/  I ALPH (6 ) , NALPH (5 ) , ID (9 ,3 ) , IR (300 , 4 )  ,  IRD  (30  , 6 )  LOU  60 

C           THE  FOLLOWING  CARDS  ARE  NEEDED  ONLY  FOR  THE  OPERATIONS  LOU  70 

COMMON  /ICODTP/  NITP,LITP  LOU  80 

COMMON  /CODETP/  ITP(10,4)  LOU  90 

COMMON  /TAPE/  NAME4 (2) ,  NTPCT , IPUNCP , I  NUN IP (L1TP  LOU  100 
C         THIS  SUBROUTINE  CHECKS  TO  SEE  IF  FIRST  WORD  AND  SOMETIMES  SECOND    LOU  102 

C        WORD  ON  COMMAND  CARD  IS  A  LEGITIMATE  COMMAND  LOU  104 

C         IF  COMMAND  IS  FOUND  LI  AND  L2  ARE  ASSIGNED  A  VALUE  LOU  106 

C         IF  COMMAND  IS  NOT  FOUND  IN  THE  DICTIONARY  LI  IS  SET  EQUAL  TO  ZERO  LOU  108 

q         *************************************************************  LOU  110 

L1=0  LOU  120 

DO  10  1=1, NIR  LOU  130 

IF  (NAME (1) . NE . IR ( I ,1) .OR .NAME (2 ) . NE . IR ( I , 2 ) )  GO  TO  10  LOU  140 

L1=IR(I,3)  LOU  150 

L2=IR (I ,4)  LOU  160 

C           THE  FOLLOWING  CARDS  ARE  NEEDED  ONLY  FOR  TAPE  OPERATIONS  LOU  170 

IF  (NAME(l) .NE.IR(50,1) )  RETURN  LOU  180 

C           NAME (3 )=TAP      NAME (4 )=E  LOU  190 

IF  (NAME(3) .EQ. 14623 .AND. NAME(4) .EQ. 3645)  GO  TO  40  LOU  200 

C         *************************************************************  LOU  210 

RETURN  LOU  220 

10        CONTINUE  LOU  230 

DO  20  1=1, NID  LOU  240 

IF  (NAME (1 ) .NE . ID ( I , 1 ) .OR . NAME (2 ) . NE . ID ( I , 2 ) )  GO  TO  20  LOU  250 

L1=ID(I,3)  LOU  260 

GO  TO  80  LOU  270 

20        CONTINUE  LOU  280 

DO  30  I=1,NIRD  LOU  290 
IF  (NAME(l) .NE. IRD (1,1) .OR. NAME (2) .NE . IRD (1 ,2) .OR. NAME (3) .NE. IRD (I LOU  300 

1,3) .OR .NAME (4) .NE . IRD ( I ,4) )  GO  TO  30  LOU  310 

L1=IRD(I,5)  LOU  320 

L2=IRD(I,6)  LOU  330 

RETURN  LOU  340 

30        CONTINUE  LOU  350 

C           THE  FOLLOWING  CARDS  ARE  NEEDED  ONLY  FOR  TAPE  OPERATIONS  LOU  360 

40        DO  50  I=1,NITP  LOU  370 

IF  (NAME (1 ) . NE . ITP ( I , 1 ) .OR .NAME (2 ) . NE . ITP ( I , 2 ) )  GO  TO  50  LOU  380 

L1=ITP(I,3)  LOU  390 

L2=ITP(I,4)  LOU  400 

GO  TO  60  LOU  410 

50        CONTINUE  LOU  420 

RETURN  LOU  430 

60        IF  (L1.GT.47)  RETURN  LOU  440 

DO  70  1=1,6  LOU  450 

IF  (NAME4 (1 ) . NE . I ALPH ( I ) )  GO  TO  70  LOU  460 

L2=I+1  LOU  470 

RETURN  LOU  480 

70       CONTINUE  LOU  490 

Q  **********************************  ********************************|_Q(J  5QQ 

RETURN  LOU  510 

C           THE  FOLLOWING  CARDS  ARE  NEEDED  ONLY  FOR  TAPE  OPERATIONS  LOU  520 

80        IF  (L1.NE.5)  GO  TO  90  LOU  530 

C           NAME (3 )=TAP      NAME (4 )=E  LOU  540 

IF  (NAME(3) .EQ. 14623. AND. NAME(4) .EQ. 3645)  GO  TO  40  LOU  550 
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c 

TMTf     ^inn     111  *  c        r  A  A        11  1 

THIS  CARD  YYA5     500  L2=l 

1  All 

LOU 

560 

90 

L2=l 

LOU 

570 

/■» 
C 

**************************************************************** 

■  i  nil 
LUU 

con 
580 

lr    (Ll.tU..!)   bU   IU  11U 

1  All 

LUU 

C  A  A 

590 

UU  1UU   1=1 , o 

LUU 

/Aft 

600 

T  C      /  M  A  MC  /  3  \     KIT     T  A  1  D  U  /  T  \  \     Is  A    Tfl     1  A  A 

lr    (NAMt (3 ) . Nt .  lALrn ( 1 ) )   bU   IU  100 

1  All 

LOU 

Z  1  A 

610 

L2=l+1 

1  All 

LUU 

L  *>  A 

620 

DCTIIDU 

Kt 1 UKN 

1  All 

LUU 

LI  f\ 

630 

1  A  A 
100 

nAMT  T  Ml  IC 

LUN 1 1 nut 

1  Al  1 

LUU 

L  A  A 

640 

TC     <\  ^     MC    0  \  DCTIIDM 

lr    (Ll.Nt.2)    Kt 1 UKN 

1  Al  1 

LUU 

641 

TC     H  0    MC    1  \  DCTIIDM 

lr    (L2.Nt.l)  KtlUKN 

1  All 

LUU 

L  A  1 

642 

Tr      /  U  A  MC  /  Q  \     MC     1  A  £  3  1      A  M  A.     MA  MC  /  A  \     MC     1  L  A  ZL  \  DCTIIDM 

lr    (NAMt (3 )  . Nt . 1063 1 . AND . NAMt (4 )  . Nt .  3645 )  KtlUKN 

1  All 

LUU 

LAI 

643 

0 

tuc  rnuuAun   tc  ddtmt  matc 
1  nt  LUMMANU   lb  rKlNI    NU  1 1 

1  All 

LUU 

L  A  A 

644 

L  1=13 

1  All 

LUU 

LAC 

645 

1  1     1  1 

L2=13 

1  All 

LUU 

L  A  L 

646 

Kt 1 UKN 

1  All 

LUU 

L  C  A 

650 

1  1  A 

HO 

UU  120   1=1 , b 

1  All 

LUU 

L  L  A 

660 

TC      /  hi  A  MC  /  O  \     KIC     II  A  1  DU  /  T  \  \     prt    TA     1  1  A 

lr    (NAMt  (3  )  .  Nt .  NALrrl  ( 1 )  )   liU   IU  120 

1  All 

LUU 

£  7  A 

670 

1  1     T  .  1 

L2=l +2 

1  All 

LUU 

/on 
680 

DCTIIDM 
Kt 1 UKN 

1  All 

LUU 

L  Q  A 

690 

1  1  A 

120 

AAUT  T  Ml  IC 

LUN 1 1 NUt 

1  All 

LUU 

7  A  A 

700 

nrn  mil 

RETURN 

LOU 

710 

END 

LOU 

720 
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c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 


SUBROUTINE  MATRIX 

VERSION    5.00         MATRIX  5/15/70 


C 

c 

c 


10 

20 

30 

40 

C 
C 
C 

50 
60 


70 


C 
C 
C 

80 


MAT  10 

MAT  20 

MAT  30 

L2=l    ADD  MATRICES  A+B    MADD  A(f)  N , M,  TO  B(,)  N,M  AND  S  ORE  IN  C (MAT  40 

L2=2    SUB  MATRICES  A-B    MSUB  A(,)  N  ,M  FROM  B(,)N,M  AND  STORE  IN  C  (MAT  60 

L2=3    TRANSPOSE  MATRIX  MTRANS  A(,)  N,M  AND  STORE  IN  C(,)  MAT  80 

TRANSPOSE  ARRAY  ATRANS  A(,)  N,M  AND  STORE  IN  C(,)  MAT  90 


L2=4 
L2=5 
L2=6 
L2=7 
L2=8 


ARRAY  ADD 
ARRAY  SUBTRACT 
ARRAY  MULTIPLY 
ARRAY  DIVIDE 
ARRAY  RAISE 


AADD 
ASUB 
AMULT 
ADIV 
ARAISE 

GENERAL  FORMS  FOR  ARRAY  OPERATIONS 


MAT  100 

MAT  110 

MAT  120 

MAT  130 

MAT  140 

MAT  150 

)  N,K  STORE  IN  C(,)  ARRAY  BY  ARRAY  MAT  160 

)          STORE  IN  C(,)  ARRAY  BY  ARRAY  MAT  170 

STORE  IN  C(,)  ARRAY  BY  COLUMN        MAT  180 

STORE  IN  C(,j  ARRAY  BY  CONSTANT    MAT  200 

MAT  220 

MAT  230 

COMMON  /BLOCKD/  IARGS (100 ), KIND ( 100 ) ,ARGTAB ( 100 ), NRMAX ,NROW, NCOL ,NMAT  240 


A( 
A( 
A( 
A( 


) 


N ,  M  B( 
N,M  B( 
N,M  K 
N  ,M  X 


COMMON  /BLOCRC/  NRC ,RC (12600) 


1ARGS,VWXYZ(8) ,NERROR 
DIMENSION  ARGS(IOO) 
EQUIVALENCE  (ARGS (1) ,RC  (12501) ) 
COMMON  /SCRAT/  NS , NS2 , A (13500 ) 
COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG 

CHECK  TO  SEE  IF  WE  HAVE  CORRECT  NUMBER  OF  ARGUMENTS 

NP=NARGS 

IF  (L2-3)  10,20,30 

IF  (NARGS .NE .8 . AND .NARGS .NE .10)  GO  TO  40 
GO  TO  50 

IF  (NARGS. NE. 6)  GO  TO  40 
GO  TO  50 

IF(NARGS.LT.7.0R.NARGS.GT.10.0R.NARGS.EQ.9)  GO  TO  40 

GO  TO  50 

CALL  ERROR  (10) 

RETURN 

CHECK  TO  SEE  IF  ALL  ARGUMENTS  ARE  INTEGERS 

IF (L2 .GT .3 .AND .NARGS .EQ .7 )  GO  TO  70 

J=NARGS 

CALL  CKIND  (J) 

IF  (J.EQ.O)  GO  TO  80 

CALL  ERROR  (3) 

GO  TO  80 

I SAVE=KIND (NARGS ) 

KIND (NARGS )=KIND (NARGS-2 ) 

KIND (NARGS-2 )=KIND (NARGS-1 ) 

KIND(NARGS-1)=ISAVE 

NARGS=NARGS-1 

GO  TO  60 

CHECK  TO  SEE  IF  DIMENSIONS  ARE  CORRECT  IF  THEY  ARE  GIVEN 
IF  (NP.NE.10)  GO  TO  90 

IF  (IARGS (3) .EQ. IARGS (7) .AND .IARGS (4) .EQ . IARGS (8) )  GO  TO  90 
CALL  ERROR  (3) 


MAT  250 
MAT  260 
MAT  270 
MAT  280 
MAT  290 
MAT  300 
MAT  310 
MAT  320 
MAT  330 
MAT  340 
MAT  350 
MAT  360 
MAT  370 
MAT  380 
MAT  390 
MAT  400 
MAT  410 
MAT  415 
MAT  420 
MAT  430 
MAT  440 
MAT  450 
MAT  460 
MAT  470 
MAT  480 
MAT  490 
MAT  500 
MAT  510 
MAT  520 
MAT  530 
MAT  540 
MAT  550 
MAT  560 
MAT  570 
MAT  580 
MAT  590 
MAT  600 
MAT  610 
MAT  620 
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DCTIIDM 

Kt 1 UKN 

MA \    be  5 

c 

HAT     L n A 

MA  1  630 

t 

pucri/    T(l    CCC    TC    ADPII MET  M  T  C  ADC 
LntUN    1U   ot.t    lr    AKuUMtlM  1  i  AKt 

UU  1  Ur 

RANGE 

MA  T    L  A n 

MA  1  640 

U 

MAT     L L A 

MA  1  660 

A  A 

IF(  (L2.LT.3 .0R.L2 .GT.3) .AND .KIND (NP) 

• 

■  u ) 

C  C\    Tft     1  A  A 

bU    ! U  1UO 

MAT     L 7  A 

MA  1    6  7  0 

MAT  /OA 

MA  I  680 

UU     1 U    1 j u 

MAT     L A  A 

MA  1  690 

1  A  A 

J=3 

MAT     7  A A 

MA  1  700 

IARGS(12)=IAR6S(4) 

MA  T     7  0  A 

MA  i    1  i\J 

ion 
1^0 

IARGS(11)=IARGS(3) 

MAT     7  C  A 

Mm  1    / 3  0 

IF  (NP.EQ.10)  GO  TO  210 

MAT     7  Z.  A 

MA  I  760 

IARGS(10)=IARGS(NP) 

MAT     7  7  A 

MA  1    7  7  0 

IARGS(9)=IARGS(NP-1) 

MAT  70A 

MA  1    7  80 

1  30 

IF  (NP.EQ.8.0R. (NP . EQ . 7  .AND .KIND (NP) 

NP 

n  ^  i 

bU    IU  190 

MA  T     7  Q  A 

MA  1    /  9  0 

IF(NP  E0  6)  GO  TO  160 

MA  T    0 1  A 

MA  1    o  1 0 

IARGS (6)=IARGS  (5) 

MAT     O  L A 

MA  1  860 

IARGS (8  )=1 

MAT  OTA 

MA  1  870 

IARGS(7)=IARGS(3) 

MAT     O  O  A 

MA  1  880 

IARGS (5)=1 

MAT     O  A A 

MA  1  890 

GO  TO  210 

MAT  AAA 

MA  1  900 

loU 

IARGS(8)=IARGS(3) 

MAT     A 1  A 

MA  1  910 

IARGS(7)=IARGS(4) 

MAT    Q  o  A 

MA  1  920 

GO  TO  210 

MAT     A  1  A 

MA  1  930 

i  on 
190 

IF  (NP.EQ.8)  GO  TO  200 

MATT  AT  A 
MA  11010 

IARGS(5)=IARGS(6) 

MA  T  1  A  O  A 

MA  1  1 0  d  0 

IARGS(6)=IARGS(7) 

M  A  T  1  A  7  A 

MA  I  1030 

O  A  A 

zoo 

IARGS(8)=IARGS(4) 

M  A  T  1  A  A  A 
MA  11040 

IARGS(7)=IARGS(3) 

MA  T  1  A  C  A 

MA  1 1030 

7  T  A 

2  10 

CALL  MTXCHK  (J) 

MA  T  T  A  L  A 

MA  1 1060 

IF   (J-l)  240,220,230 

MA  T 1  A  7  A 

MA  110/0 

*5  0  A 

£20 

CALL  ERROR  (3) 

MA  T  1  A  O  A 

MA  1 1080 

RETURN 

MA  T  1  A  A  A 

MA  11090 

1  7  A 

230 

CALL  ERROR  (17) 

M  A  T  1  T  A  A 
MA  11100 

RETURN 

MA  T 1  1  1  A 

MA  11110 

K> 

* 

mat i ion 
MA  1  J.  i  c  0 

CHECK  TO  SEE  IF  THERE  WERE  PREVIOUS 

ERRORS 

MA  T 1  T  7  A 
MA  11130 

L 

* 

MA  T  1  1  A  A 
MA  11140 

J  4  0 

IF  (NERR0R.NE.0)  RETURN 

MAT 1  1  C  A 
MA  1 1130 

C 

MA  Tl  1 tft 
MA  1 lloO 

r* 
L 

SUM  ELEMENTS  IN  SCRATCH  AREA 

MATT  1  Tft 
MA  111/0 

L 

SUBTRACT  ELEMENTS  IN  SCRATCH 

AREA 

MA  Tl  1  Oft 
MA  1 1 180 

C 

PRODUCTS  AND  QUOTIENTS  FORMED 

USING 

DOUBLE 

r KtU 1 o 1 UN  IN 

CPDATPLI  ADMAT11AA 

bUKAlUH  AKMA 11190 

c 

TRANSPOSE  IN  SCRATCH  AREA 

MATT  1 A  A 
MA  1  1200 

C 

MAT 1  7 1  A 
MA  1  1110 

IR0W=IARGS(3) 

MA  Tl 91ft 
MA  1  lii\i 

IC0L=IARGS(4) 

MAT  1  7  7 ft 
MA  1  Li 

NR0WPP=NR0W 

MATT  7 Ah 
MA  1 1140 

IF   (L2-3)  260,250,290 

MAT 1 7  C  ft 
MA  1 1Z30 

250 

1 1 B= I COL 

MA  Tl lift 
MA  I l£O0 

JJB=IR0W 

MA  Tl  nn 
MA  I  1 c  1  0 

NR0WPP=0 

MAT 1 7  0ft 
MA  1  l£OU 

K=l 

MAT 1 7  0ft 
MA  1  1  £  9  0 

GO  TO  280 

MAT 1  7  ft  ft 
MA  1 13U0 

260 

NR0WP=NR0W 

MA  T 1  7 1  ft 
MA  11310 

IBP=IARGS(5) 

MAT1  1"if\ 
MA  1 13tU 

270 

IIB=IR0W 

MATT  17ft 
MAI 133U 

JJB=IC0L 

MAT 1  7  A  A 

MA  11340 

K=0 

MAT 1 7  C  ft 
MA  1 1330 

280 

IS=1 

MAT1360 
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290 


300 
310 

320 
C 


330 
340 
350 
360 

365 
370 

380 

390 

400 

410 

415 

420 

430 

440 
450 

460 
470 
480 
490 
500 

510 


I AP=I ARGS (1 ) 
GO  TO  320 

IF  (NP.GE.8)  GO  TO  260 

IF  (KIND (NP )  .EQ.l)  GO  TO  300 

IBP=IARGS(5) 

GO  TO  310 

IARGS(9)=IARGS(5) 

NROWP=0 

GO  TO  270 

DO  510  J=1,JJB 

COMPUTE  ADDRESSES 

IA=IAP+(J-1)*K 

IB=IBP 

DO  500  1=1, 1  IB 

GO  TO  (330,340,370,380,390,400,410,420),  L2 

A(IS)=RC(IA)+RC(IB) 

GO  TO  470 

A(IS)=RC(IA)-RC(IB) 
GO  TO  470 

A(IS)=RC(IA)*RC(IB) 
GO  TO  470 

IF(RC(IB) .EQ.O  .0)  GO  TO  365 

A(IS)=RC(IA) /RC(IB) 

GO  TO  470 

A(IS)=0.0 

GO  TO  470 

A(IS)=RC(IA) 

IA=IA+NROW 

GO  TO  490 

IF  (NP.GE.8. OR. (KIND(NP) . EQ . 0 . AND . NP  .  LT  .  8 ) )  GO  TO  330 

A(IS)=RC(IA)+ARGS(NP-2) 

GO  TO  480 

IF  (NP.GE.8. OR. (KIND (NP) . EQ . 0 . AND  .  NP  .  LT  .  8 ) )  GO  TO  340 

A(IS)=RC(IA)-ARGS(NP-2) 

GO  TO  480 

IF  (NP.GE.8. OR. (KIND (NP ) . EQ . 0 . AND . NP  .  LT  .  8 ) )  GO  TO  350 

A(IS)=RC(IA)*ARGS(NP-2) 

GO  TO  470 

IF  (NP.GE.8. OR. (NP.LT.8.AND.KIND(NP) .EQ.O) )  GO  TO  360 

IF(ARGS(NP-2) .EQ.O.O)  GO  TO  415 

A(IS)=RC(IA) /ARGS(NP-2) 

GO  TO  470 

A(IS)=0.0 

GO  TO  470 

IF  (NP.GE.8. OR. (NP.LT.S.AND.KIND(NP) .EQ.O) )  GO  TO  440 
IF  (RC(IA))  430,460,430 
A(IS)=FEXP2 (RC(IA) ,ARGS(NP-2) ) 
GO  TO  470 

IF   (RC(IA))  450,460,450 

A(IS)=FEXP2(RC(IA) ,RC(IB) ) 

GO  TO  470 

A(IS)=0.0 

IB=IB+1 

IA=IA+1 

IS=IS+1 

CONTINUE 

IAP=IAP+NROWPP 

IBP=IBP+NROWP 

CONTINUE 


MAT1370 
MAT1380 
MAT1390 
MAT1400 
MAT1410 
MAT1420 
MAT1430 
MAT1440 
MAT1450 
MAT1460 
MAT1465 
MAT1470 
MAT1480 
MAT1490 
MAT1500 
MAT1510 
MAT1520 
MAT1530 
MAT1540 
MAT1550 
MAT1560 
MAT1562 
MAT1564 
MAT1566 
MAT1570 
MAT1580 
MAT1590 
MAT160Q 
MAT1610 
MAT1620 
MAT1630 
MAT1640 
MAT1650 
MAT1660 
MAT1670 
MAT1680 
MAT1690 
MAT1700 
MAT1710 
MAT1712 
MAT 17 14 
MAT1716 
MAT1720 
MAT1730 
MAT1740 
MAT1750 
MAT1760 
MAT1770 
MAT1780 
MAT1790 
MAT1800 
MAT1810 
MAT1820 
MAT1830 
MAT1840 
MAT1850 
MAT1860 
MAT1870 
MAT1880 
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C         *  MAT1890 

C         MOVE  SUMS  TO  WORKSHEET  MAT1900 

C         MOVE  DIFFERENCES  TO  WORKSHEET  MAT1910 

C         MOVE  ARRAY  PRODUCT  TO  WORKSHEET  MAT1920 

C         MOVE  ARRAY  QUOTIENT  TO  SORKSHEET  MAT1930 

C         MOVE  TRANSPOSE  TO  WORKSHEET  MAT1940 

C         MOVE  RAISED  MATRIX  TO  WORKSHEET  MAT1950 

C         *  MAT1960 

IF  (L2.NE.3)  GO  TO  520  MAT1970 

ICP=IARGS(5)  MAT1980 

GO  TO  530  MAT1990 

520      ICP=IARGS(9)  MAT2000 

530      IS=1  MAT2010 

DO  550  J=1,JJB  MAT2020 

IC=ICP  MAT2030 

DO  540  1=1 , 1  IB  MAT2040 

RC(IC)=A(IS)  MAT2050 

IC=IC+1  MAT2060 

IS=IS+1  MAT2070 

540      CONTINUE  MAT2080 

ICP=ICP+NROW  MAT2090 

550      CONTINUE  MAT2100 

RETURN  MAT2110 

END  MAT2120 
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c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 


SUBROUTINE  MOAMAD 

VERSION    5.00         MDAMAD  5/15/70 

SUBROUTINE  MDAMAD 

* 


R  VARNER  9/26/67 


C 

c 
c 

c 
c 
c 


c 
c 
c 
c 


10 

20 
30 


40 

50 

C 
C 
C 

60 


SUBROUTINE  TO  PRE  OR  POST  MULTIPLY  A  MATRIX  BY  A  DIAGONAL  STORED 
AS  A  COLUMN 
L2=l  M(AD) 

MATRIX  A  IS  POSTMULTIPLIED  BY  THE  DIAGONAL  D  STORED  IN  COL  I 
GENERAL  FORM  OF  COMMAND 

M(AD)  A(,)  N,K,     D  IN  COL    I     STORE  IN  C(() 
L2=2  M(AD) 

MATRIX  A  IS  PREMULTIPLIED  BY  THE  DIAGONAL  D  STORED  IN  COL  I 
GENERAL  FORM  OF  COMMAND 

M(DA) ,  A(()  N,K    K  IN  COL    I    STORE  IN  C(,) 

* 

COMMON  /SCRAT/  NS , NS2 , A ( 13500 ) 
COMMON  /BLOCRC/  NRC  ,RC  (12600) 

COMMON  /BLOCKD/  I ARGS ( 100 ) ,KIND ( 100 ) , ARGTAB ( 100 ) ,NRMAX , NROW, NCOL 
1ARGS,VWXYZ(8) ,NERROR 
DIMENSION  ARGS(IOO) 
EQUIVALENCE  (ARGS  (1 )  ,RC  (12501 ) ) 
COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG 

CHECK  FOR  CORRECT  NUMBER  OF  ARGUMENTS 

IF  (NARGS.NE.7)  CALL  ERROR  (10) 
* 

CHECK  TO  SEE  THAT  ALL  ARGUMENTS  ARE  INTEGERS 


MDA 
MDA 
MDA 
MDA 
MDA 
MDA 
MDA 
MDA 
MDA 


10 
20 
30 
40 
50 
60 
70 
80 
90 


J=NARGS 

CALL  CKIND  (J) 

IF  (J.NE.O)  CALL  ERROR 


(3) 


CHECK  TO  SEE  IF  DIMENSIONS  ARE  OUT  OF  RANGE 
COMPUTE  ADDRESSES  OF  COLUMNS 

IARGS(12)=IARGS(4) 

IARGS(11)=IARGS(3) 

IARGS(10)=IARGS(7) 

IARGS(9)=IARGS(6) 

IARGS(8)=1 

GO  TO  (10,20)  ,  L2 

IARGS(7)=IARGS(4) 

GO  TO  30 

IARGS(7)=IARGS(3) 

IARGS(6)=IARGS(5) 

IARGS(5)=1 

J=3 

CALL  MTXCHK  (J) 
IF  (J-l)  60,40,50 
CALL  ERROR  (3) 
RETURN 

CALL  ERROR  (17) 
RETURN 

CHECK  FOR  PREVIOUS, ERRORS 

IF  (NERROR.NE.O)  RETURN 
IP=IARGS(4) 


MDA  100 

MDA  110 

MDA  120 

MDA  130 

MDA  140 

MDA  150 

MDA  160 

MDA  170 

,NMDA  180 

MDA  190 

MDA  200 

MDA  210 

MDA  220 

MDA  230 

MDA  240 

MDA  250 

MDA  260 

MDA  270 

MDA  280 

MDA  290 

MDA  300 

MDA  310 

MDA  320 

MDA  330 

MDA  340 

MDA  350 

MDA  360 

MDA  370 

MDA  380 

MDA  390 

MDA  400 

MDA  410 

MDA  420 

MDA  430 

MDA  440 

MDA  450 

MDA  460 

MDA  470 

MDA  480 

MDA  490 

MDA  500 

MDA  510 

MDA  520 

MDA  530 

MDA  540 

MDA  550 

MDA  560 

MDA  570 

MDA  580 

MDA  590 
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ID     T  ADPC  /  1  \ 

Jr=lAKbb (i ) 
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640 
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MUA 
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650 

TO  A 
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OOU 

Q  A 
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t  no  T  hoc c/ci 
1 Ur= 1 AKuo (D ) 

un  a 

MUA 

OoU 

TD     T  A  DP  C  / O  \ 

Id=1 AKbb (7 ) 

un  a 
MUA 

&7U 

nn    liA    T     1  TD 

UU   110   1=1 , Ir 

MA  A 

MUA 

7  A  A 

700 

ID  TDD 

un  a 
MUA 

7  1  A 
/  10 

nn  i  fin   i— i    i  d 
Uu   1UU  J  =  i , J  r 

Mn  A 

MUA 

7  O  A 

DP  / T  Q \     DP / TH \ *DP  M  A  1 
Kb (ID) =Kb ( 1 U )    Kb ( 1 A ) 

Mn  A 

MUA 

7  %  t\ 
1  3\J 

t  n    T  t\  .  T  0 
1 U= 1 U  +  l £ 

Mn  A 

MUA 

7  A  A 

T  A     T  A  ,  1 

1 A=l A+l 

Mn  A 
MUA 

7  C  A 

7  b0 

T  D     T  D  .  H 
1 D=lD+l 

un  a 
MUA 

7  60 

1  A  A 

1UU 

P  AWT  T  Ml  IE 
bUN 1 1 NUt 

un  a 
MUA 

7  7  A 

/  /  U 

YD     T  D  i  UD  Alii     1  D 
1 D=l D+NKU W— J  r 

un  a 
MUA 

7  D  A 

/  oU 

T  A     T  A  i  MDAUf     1  D 
1 A=1A+NKUW— Jr 

un  a 
MUA 

7  Q  A 
/  VU 

T  no    T  AD  .  T 1 

1 Ur=l Ur  +  1 1 

un  a 
MUA 

O  A  A 

oUU 

110 

P  A  M  T  T  hi  1 1 C 

bUN 1 1 Nut 

un  a 
MUA 

Q  1  A 

olU 

RETURN 

MDA 

820 

END 

MDA 

830 

150 


SUBROUTINE  MEIGEN  ME  I  10 

C         VERSION    5.00         MEIGEN         5/15/70  ME I  20 

C         SUBROUTINE  MEIGEN  WRITTEN  BY  R  VARNER  4/4/68                                   ME  I  30 

C         *  ME  I  40 

C         SUBROUTINE  TO  COMPUTE  EIGENVALUES  AND  EIGENVECTORS                            ME  I  50 

C              GENERAL  FORMS  OF  COMMANDS  ME  I  60 

C                   MEIGEN    A(,,++)  R=((  C=, ,  STORE  VALUES  IN  COL  ++                     ME  I  70 

C                   MEIGEN    A(,,++)  R=,,  C=, ,  STORE  VECTORS  IN    B(,,++)                ME  I  80 

C                   MEIGEN    A(,,++)  R=,,  C=,  ,  STORE  VALUES  IN  COL  ++                     ME I  90 

C                                                               STORE  VECTORS  IN    B(,,++)                ME  I  100 

C              BOTH    R  AND  C    MUST  BE  SPECIFIED  ME I  110 

C              NARGS=  5    COMPUTE  ONLY  EIGENVALUES  ME  I  120 

C              NARGS='6    COMPUTE  ONLY  EIGENVECTORS  ME  I  130 

C              NARGS=  7    COMPUTE  EIGENVALUES  AND  VECTORS  ME  I  140 

C         *  ME I  150 

COMMON  /BLOCRC/  NRC , RC ( 12600 )  ME  I  160 
COMMON  /BLOCKD /  IARGS ( 100 ), KIND ( 100 ) .ARGTAB ( 100 ), NRMAX , NROW,NCOL  ,NMEI  170 

1ARGS ,VWXYZ (8 ) ,NERROR  ME I  180 

DIMENSION  ARGS(IOO)  ME  I  190 

EQUIVALENCE  (ARGS ( 1 ), RC ( 12501 ) )  ME I  200 

COMMON  /SCRAT/  NS (NS2 , A  (13500 )  ME I  210 

DIMENSION  ISWCH(2)  ME I  220 

C         *  ME  I  230 

C         CHECK  TO  BE  SURE  THAT  MATRIX  IS  NO  BIGGER  THAN  54X54  ME  I  240 

C         *  ME I  250 

IF  (IARGS(3) .NE.IARGS(4) )  CALL  ERROR  (230)  ME  I  260 

IF  (IARGS(3)**2.GT.NS2)  CALL  ERROR  (23)  ME I  270 

C         *  ME I  280 

C         CHECK  FOR  CORRECT  NUMBER  OF  ARGUMENTS  ME  I  290 

C         *  ME I  300 

IF  (NARGS . LT . 5 .OR .NARGS .GT . 7 )  CALL  ERROR  (10)  ME  I  310 

C         *  ME I  320 

C         CHECK  TO  SEE  IF  ARGUMENTS  ARE  ALL  INTEGERS  ME  I  330 

C  ME I  340 

J=NARGS  ME I  350 

CALL  CKIND  (J)  ME I  360 

IF  (J.NE.O)  CALL  ERROR  (3)  ME I  370 

C         *  ME I  380 

C         CHECK  TO  SEE  IF  DIMENSIONS  ARE  OUT  OF  RANGE                                        ME  I  390 

C         COMPUTE  ADDRESSES  ME I  400 

C         *  ME I  410 

ISWCH(2)=NARGS-4  ME I  420 

ISWCH(1)=0  ME I  430 

IF  (NARGS. EQ. 6)  GO  TO  10  ME I  440 

IADD=1  ME I  450 

CALL  ADRESS  (5, J)  ME I  460 

IF  (J.LE.O)  CALL  ERROR  (11)  ME I  470 

C         *  ME I  480 

C         J  CONTAINS  ADDRESS  OF  COLUMN  ME I  490 

C         *  ME I  500 

IF  (NARGS. EQ. 5)  GO  TO  20  ME I  510 

IARGS(5)=IARGS(6)  ME I  520 

IARGS(6)=IARGS(7)  ME I  530 

10        IADD=2  ME I  540 

IARGS(7)=IARGS(3)  ME I  550 

IARGS(8)=IARGS(4)  ME I  560 

GO  TO  30  ME I  570 

20        ISWCH (1 )=1  ME I  580 

30        CALL  MTXCHK  (IADD)  ME  I  590 
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IF    (1AUU-1)  60,40,50 

IIC  T 

ME  I 

/  A  A 

600 

40 

CALL  ERROR   (3 ) 

IIC  T 

ME  I 

/  1  A 

610 

DTTIIDM 

Rt 1  URN 

IIC  T 

Mb  I 

/OA 

620 

C  A 

50 

CALL  ERROR  (17) 

iir  t 

Mbl 

/OA 

630 

DtTIIDkl 

RE  I  URN 

Mbl 

/  A  A 

640 

C 

♦ 

tier  t 

ME  I 

650 

c 

purri/   cad   ooti/  t  ni  ic  eoDADC 
CHECK  FOR  PREVlUUb  ERRURb 

IIC  T 

Mbl 

/  /  A 

660 

A 

c 

* 

IIC  T 

Mbl 

L  "T  A 

670 

60 

T  C      /MCDDAD     MC     f\\  DCTIIDU 

1 r    (NERRUR . NE . 0 )   KE 1  URN 

IIC  T 

Mbl 

680 

TAD     TADTC  /  C\ 

1 br=l ARbb ( D ) 

Mbl 

690 

IG=IARGS(1) 

IIC  T 

Mbl 

1  A  A 

700 

CALL  HDIAG  (RC ( IG ) , I ARGS (3 ) , ISWCH , A , RC ( J ) , RC ( IGP ) , NROW, A (3000 ) ) 

ne  t 

ME  I 

T  1  A 

710 

c 

* 

IIC  T 

ME1 

T  1  A 

7Z0 

C 

RC(IG)  IS  LOCATION  OF  MATRIX  TO 

BE 

DIAGONALIZED 

IIC  T 

ME1 

^  O  A 

730 

c 

IARG(3)  GIVES  SIZE  OF  MATRIX 

IIC  T 

ME1 

740 

c 

ISWCH  (1)=1                         IF  ONLY 

EIGENVALUES  ARE  TO  BE  COMPUTED 

IIC  T 

ME1 

T  C  A 

750 

c 

ISWCH  (1)=0        COMPUTE  EIGENVALUES 

AND 

EIGENVECTORS 

ne  t 
ME  I 

-T  /  A 

760 

c 

ISWCH  (2)  =  NARGS-4        AND  IS  USED 

FOR 

STORING  RESULTS 

ne  t 
ME1 

770 

f 

t 

A    IS  LOCATION  OF  SCRATCH  AREA 

ME  1 

ton 
780 

C 

RC(J)  TELLS  WHERE  TO  STORE  EIGENVALUES 

Me  t 
ME  1 

7QA 

790 

c 

RC(IGP)      IS  WHERE  EIGENVECTORS 

ARE 

STORED 

lie  t 

ME  I 

AAA 

800 

c 

lie  t 

ME1 

A  1  A 

810 

RETURN 

ME  I 

820 

END 

ME  I 

830 

152 


SUBROUTINE  MISC2 

MIS 

10 

c 

VERSION    5.00          MISC2  5/15/70 

MIS 

20 

COMMON  /BLOCRC/  NRC  , RC  ( 12600 ) 

MIS 

30 

COMMON  /BLOCKD /  IARGS(IOO) ,KIN0(100) ,ARGTAB(100) , NRMAX ,NROW,NCOL ,  NMIS 

40 

1ARGS(VWXYZ(8) ,NERROR 

MIS 

50 

DIMENSION  ARGS(IOO) 

MIS 

60 

EQUIVALENCE  (ARGS (1) ,RC  (12501) ) 

MIS 

70 

COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG 

MIS 

80 

COMMON  /SCRAT/  NS ,NS2 , A  (13500 ) 

MIS 

90 

c 

SUBROUTINE  BY  CARLA  MESSINA    NSRDS  -  NBS    JULY  1967 

MIS 

100 

c 

MIS 

110 

c 

L2=4      IS      EXPAND  $$  TO  ,,  POWER  IN  INTERVALS  OF  START 

STORE  +MIS 

120 

c 

THE  POWERS  MAY  BE  INTEGER  OR 

NOT 

MIS 

130 

c 

L2=l      IS      CLOSE  UP  ROWS  HAVING  **  IN 

++,++,  ETC 

MIS 

140 

c 

L2=2      IS      COUNT  LENGTH  OF  COLUMN  ++, 

STORE  IN  COLUMN  ++ 

MIS 

150 

c 

L2=3      IS      SHORTEN  COL  ++  FOR  COL  ++  = 

=  **  STORE  IN  COL  ++ 

AND  COLMIS 

160 

c 

L2=5      IS      DUPLICATE  ,  ,  TIMES  THE  ARRAY  IN  , ,  ++  R=(f  C=, 

,  START  MIS 

170 

c 

STORING  IN  ,,  ++ 

MIS 

180 

c 

MIS 

190 

IF  (NARGS-2)  10,40,40 

MIS 

200 

10 

K=10 

MIS 

210 

20 

CALL  ERROR  (K) 

MIS 

220 

30 

RETURN 

MIS 

230 

40 

GO  TO  (50,80,50,340,540)  ,  L2 

MIS 

240 

50 

IF  (KIND (L2 ) )  60,60,70 

MIS 

250 

60 

K=3 

MIS 

260 

GO  TO  20 

MIS 

270 

70 

KIND(L2)=0 

MIS 

280 

ARG1=ARGS(L2) 

MIS 

290 

IARGS(L2)=IARGS(L2+1) 

MIS 

300 

80 

CALL  CHKCOL  (J) 

MIS 

310 

IF  (J)  60,90,60 

MIS 

320 

90 

DO  100  I=1,NARGS 

MIS 

330 

100 

IARGS(I)=IARGS(I)-1 

MIS 

340 

IF  (L2-2)  120,120,110 

MIS 

350 

110 

IF  (NARGS-5 )  10,120,10 

MIS 

360 

120 

IF  (NERROR.NE.O)  GO  TO  30 

MIS 

370 

IF  (NRMAX)  130,130,140 

MIS 

380 

130 

K=9 

MIS 

390 

GO  TO  20 

MIS 

400 

140 

IF  (L2-2)  150,210,250 

MIS 

410 

C 

CLOSE  UP 

MIS 

420 

150 

DO  200  J=2,NARGS 

MIS 

430 

K=IARGS(J) 

MIS 

440 

M=l 

MIS 

450 

DO  170  1=1, NRMAX 

MIS 

460 

J1=K+I 

MIS 

470 

IF  (RC(Jl)-ARGl)  160,170,160 

MIS 

480 

160 

Kl=K+M 

MIS 

490 

RC(K1)=RC(J1) 

MIS 

500 

M=M+1 

MIS 

510 

170 

CONTINUE 

MIS 

520 

IF  (M-NRMAX)  180,180,200 

MIS 

530 

180 

DO  190  I=M, NRMAX 

MIS 

540 

J1=K+I 

MIS 

550 

190 

RC(J1)=0.0 

MIS 

560 

200 

CONTINUE 

MIS 

570 

GO  TO  30 

MIS 

580 

C 

COUNT 

MIS 

590 
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210 

1  i     M  n  l|  A  V 

J 1=NKMAX 

MIS  600 

1      TAOPC/1\ . MD MA V 

J=lAKbb(l)+NKMAX 

IIT  C       /  1  A 

MIS  610 

AA    13A    T     1  KIDMAY 

UU   Z3U  1=1,NKMAA 

£  J  T  C      /  a  a 

Wllb  620 

T  r      /  D  P  /   1  \  \     OAA     O  O  A     0  VI  A 

IF    (KL(J))  Z4U,ZZU,Z4U 

A  J  T  C     Z  O  A 

Mlb  630 

O  O  A 

220 

J 1=J 1-1 

11 T  C     Z  A  A 

MIS  640 

O  O  A 

230 

J=J  -1 

IIT  A     /  r  r\ 

MIS  650 

A  A  f\ 

240 

AKb 1=J 1 

Al  T  C      L  L  t\ 

Mlb  660 

TADPC/0\     TADPC/0\  ■  1 

lAKbb(Z)=lAKbb(Z)+l 

A  J  T  C     /  7  A 

Mlb  670 

nil  1      WCPTAD      /  A  DP  1  TADPC/*5\\ 

LALL  VtLlUK    ( AKbl , 1 AKbb (Z ) ) 

AIT  C  /OA 

Mlb  680 

bU    IU  30 

Al  T  C     /  A  A 

Mlb  690 

a 

C 

C  U  A  D  T  C  M 

bHUK 1 tN 

Ai  T  C     7  A  A 

Mlb  700 

OCA 

250 

T  C       /  II  0 11 A  V      ft  \      OA      ft  Z  A      ft  Z  A 

lr    (NKMAX-Z)  30,260,260 

AIT  C      7  1  A 

Mlb  710 

O  £.  A 

ZoU 

AA    ion       V    ">  MDMAV 

UU   ZVU     l\=Z  ,  NKMAX 

A4 T  C  7*)n 

Mlb  720 

11     T  A  DP  C  /  O  \  .V 

J  1=1 AKbb (Z 

AIT  C     7  OA 

Mlb  730 

T  C  /  A  DP  1     DP  /   11      1\\     1  7  A     O  A  A  lOA 

1 F (AKbl-KL (J  1-1 ) )  270,300,280 

Af T  C  7/in 

Mlb  740 

ft  7  A 

270 

T  C  /  A  D  A  1      DA/    M \ \       AAA      OTA  OTA 

1 F (AKbl-KL (J  1 ) )  290,310,310 

I J  T  A      7  C  A 

Mlb  750 

1  O  A 

280 

T  C  /  A  Q  A  1       QO  /    1  1    \  \       OTA      OTA  AAA 

IF (ARG1-RC ( J  1 ) )  310,310,290 

MIS  760 

zvo 

P  A  Al  T  T  Al  1  1 C 

LUN 1 INUb 

Al  T  C      7  7  A 

Mlb  770 

K=Z  03 

AIT  C      7  A  A 

Mlb  780 

P  A  0   1      CDDAD      /  1/  \ 

LALL  tKKUK  (K) 

AIT  C      7  A  A 

Mlb  790 

A  A      X  A      O  A  A 

bu   IU  320 

11  T  C  AAA 

MIS  800 

300 

AIDUAV     V  1 

NKMAX=K-1 

KIT  C     O  1  A 

Mlb  810 

PA     T  A     "2  1  A 

bU    1 U  3Z0 

KIT  C      O  O  A 

Mlb  820 

310 

AIDUAV  y 

NKMAX=K 

IIT  C      ft  o  A 

Mlb  830 

1  7  A 
3ZU 

UU   33U  1=1,NKMAA 

MT  C  QJIA 

Mlb  84U 

V     T  ADPC  /  1  \  ■  T 
K=l AKbb  ( 1 )  +1 

MT  C  oca 

Mlb  850 

1     TADPC//IN  ■  T 

J=l AKbb (4 ) +1 

MT  C  din 

Mlb  860 

It  T  A  DP  C  /  C \  iT 

M=l AKbb ( 5 ) +1 

MT  C    O  7  A 

Mlb  8 / U 

1/1      T  A  DP  C  /  O  \  .  T 

M=l  AKbb  ( Z  )  +1 

mt  c  son 
Mlb  880 

DP / U\     DP / V 1 \ 

KL  (M)=KL  (M  ) 

MT  Q  Dan 

Ml  O  07U 

330 

DP  /  1  \  nA/ui 

RC (J )=RC (K) 

14  T  C  AAA 

Mlb  900 

A  A     T  A  OA 

GO  TO  30 

II T  C     ft  i  ft 

Mlb  910 

p 
L 

tXPANU 

M  T  C     ft  o  a 

Mlb  9Z0 

340 

Tr      /AIADPC     /I  \      1A     ttCA  1A 

IF    (NAKbb-4)  10,350,10 

MT  C     O  1  A 

Mlb  V30 

1  C  A 

350 

PAI  1      AADCCC     IA     1/1  \ 

LALL  AUKtbb  (4,M) 

MT  C    Q  A n 
Mlb  740 

T  C      /  1/  1  \      Z.  A     Z.  A     1  L  A 

IF    (M )  60,60,360 

MT  C  OCA 

Mlb  7O0 

O  A 

360 

TC      /l/TAIA/1\\      Jl  A  A     O  7  A     yi  A  A 

IF    (KlNU(l))  400,370,400 

MT  c    a  L  A 

Mlb  760 

3/0 

PAII      A  n  D  C  C  C     /  1  TADPC/1\\ 

LALL  AUKtbb    ( 1  ,  1  AKbb  ( 1 )  ) 

MT  C    Q  7  A 
Ml b   7  /  U 

TC      /TADPC/1\\      Z  A     Z  A     1  Q  F\ 

IF    (lAKbb(l))  60,60,380 

MT  C    Q  o  A 

Mlb  V80 

O  A  A 

380 

1/      T  A  DP  C  /  *l  \  1 

K=IARGS (1 )-l 

MT  C  AAA 

Mlb  990 

f\A      o  A  A      T       1  AIDUAV 

DO  390   1=1 ,NKMAX 

111  r  1  AAA 

Ml  blOOO 

1     1/  .  T 

J=K  +  I 

MT  C 1  A  1  A 

MlblUlU 

390 

4    /  T  \       n  A  /    D  \ 

A ( I )=RC (J ) 

Ad  T  C  1  A  1  A 

Ml  blOZO 

A  A      T  A      4  O  A 

GO  TO  420 

M T  C 1  ftld 

Mlb 1030 

AAA 

400 

nn    i i n    T     1  MDMAV 

UU  410   1  =  1 ,  N  K  MA  A 

MT  Q1  AAA. 
Ml  JlUtU 

410 

A/T\      A  D  P  C  /  1  \ 

A ( 1 ) =AKbb ( 1 ) 

MT  C  1  A  C  A 
MlblUSU 

A  A  A 

420 

TC      /|/TUA/ft\\     A  A  f\     A  1l\     A  A  A 

IF    (K1NU(Z))  44U,430,44U 

MT  AAA 

A  1  A 

430 

A  fl  P       /  ft  v  TAOPC/ftl 

ARGS (2 )=IARGS (2 ) 

MT  C  1  A 7  A 
MlblU/U 

4  A  A 

440 

IP    (KIND (3) )  460,450,460 

MT  C  1  Aft  A 
Ml  JlUOU 

450 

A  D  A  C  /  O  \      TADrC  /  O  \ 

ARGS (3 )=I ARGS (3 ) 

MT  ci nan 
mi oiuyu 

460 

TC      /ADAC/0\#ADAC/0\\      il  7  A     jl  7  A  ilOA 

IF    (ARGS (2 ) 'ARGS (3 ) )  470,470,480 

mt  ci i nn 
Ml  51 1 UU 

470 

K=20 

MT  C 1  1  i  n 
Ml  blilU 

A  A     T  A  OA 

GO  TO  20 

mt  ci i on 

Ml  J 1  J.  C  U 

480 

TC      /AOC/ADAC"/0\\      ADC/ADAC/0\\\      A  A  A     AAA  il*7A 

IF   (ABS (ARGS (3 ) )-ABS (ARGS (2 ) ) )  490,490,470 

MT  C 1  1  1  A 
Ml  j 1 1 3 U 

490 

1  r     /  urnnAn    11  r*    a  v    a  a    ta  oa 

IF   (NERR0R . NE . 0 )  GO  10  30 

MT  C 1  1  A  A 
M15114U 

TC      /  kl  D  hi  A  V  \      I^A     1  in  CAA 

I r    (NKMAX )  130,130,500 

MT  Ci  1  C A 
ml j 11 D  U 

500 

AA        A  A  A  A    /  o  \ 

CC=ARGS(3) 

MT  C 1  1  L A 
Mlbll6U 

510 

AA      ron       T       1       II A  II 1  \J 

00  520  1=1 , NRMAX 

MT  C 1  1  7  A 
Ml  bl 1  1  U 

K=K1-1+I 

MIS1180 
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520 

RC(K)=FEXP2(A(I) ,CC) 

MIS1190 

IF  (ABS(CC)+.5E-6-ABS(ARGS(2) ) )  530,30,30 

MIS1200 

530 

CC=CC+ARGS(3) 

MIS1210 

IARGS(4)=IARGS(4)+1 

MIS1220 

CALL  ADRESS  (4,K1) 

MIS1230 

IF  (Kl)  60,60,510 

MIS1240 

C 

DUPLICATE 

MIS1250 

540 

IF  (NARGS.NE.7)  GO  TO  10 

MIS1260 

IF  (IARGS(l) .LE.O)  GO  TO  60 

MIS1270 

K1=MAX0(IARGS(1)*IARGS(4)+IARGS(6)-1,NRMAX) 

MIS1280 

IF  (Kl.GT.NROW)  GO  TO  590 

MIS1290 

J=7 

MIS1300 

CALL  CKIND  (J) 

MIS1310 

IF  (J.NE.O)  GO  TO  60 

MIS1320 

NARGS=6 

MIS1330 

NDUP=IARGS(1) 

MIS1340 

IARGS(61)=IARGS(6) 

MIS1350 

IARGS(62)=IARGS(7) 

MIS1360 

IARGS(63)=IARGS(4) 

MIS1370 

IARGS(64)=IARGS(5) 

MIS1380 

IARGS(65)=IARGS(6) 

MIS1390 

IARGS(66)=IARGS(7) 

MIS1400 

DO  550  1=1,6 

MIS1410 

550 

IARGS(I)=IARGS(I+1) 

MIS1420 

CALL  MOVE 

MIS1430 

IF  (NDUP.EQ.l)  GO  TO  580 

MIS1440 

DO  570  I=2,NDUP 

MIS1450 

DO  560  J=l,6 

MIS1460 

560 

IARGS(J)=IARGS(J+60) 

MIS1470 

IARGS(5)=IARGS(65)+(I-1)*IARGS(63) 

MIS1480 

570 

CALL  MOVE 

MIS1490 

580 

NRMAX=K1 

MIS1500 

GO  TO  30 

MIS1510 

590 

K=16 

MIS1520 

GO  TO  20 

MIS1530 

END 

MIS1540 
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SUBROUTINE  MIST  (M, B , LCHK ,NLA , IND ) 

MST 

10 

c 

VERSION    5.00         MIST  5/15/70 

MST 

20 

DIMENSION  B(l)  ,  NBC(12) 

MST 

30 

COMMON  /BLOCKD/  IARGS(IOO) ,KIND(100) ,ARGTAB (100) , NRMAX ,NROW,NCOL ,  NMST 

40 

1AR6S ,VWXYZ (8 ) ,NERR0R 

MST 

50 

a  a  ■■■  i/\  ti       (iie-  4  in  m    i      ii  A  o  t  n  m  /  a  a  v       t  t  i    j™   y  j>  a      *   *       ■    i ■  a  ii  tt      t  n  n  t  i  i  t     tin  i  at      t  n  i  i  a  ■  a  ■  i 

COMMON  /HEADER/  N0CARD  (80 ) , ITLE (60 , 6 ) , LNCNT  ,  IPRINT , NPAGE , IPUNCH 

MST 

60 

nil     ii  a 

MM=M-2 

MST 

70 

NN=NRMAX-3 

IIA  T 

MST 

80 

NC=10 

MST 

90 

M1=(M-1) /NC+1 

MST 

100 

NLU=56 

MST 

110 

tin  i  /\ 

NCA=0 

MST 

120 

nn  i  a 

NRA=0 

IIA  T 

MST 

130 

i\  a     i  a  a    i/rii     i  mi 

DO  120  KEN=1 , Ml 

IIA  T 

MST 

140 

ftlAH        IIT  kl  A    /  11  A        11      IIA  1  V 

NCP=MIN0 (NC , M-NCA) 

IIA  T 

MST 

150 

NRP=M-LCHK*NCA 

IIA  T 

MST 

160 

ii  i  r»              t  kin  i  ^  \  i&inn  r- 

NLP=(l+IND/7)*NRP+5 

IIA  X 

MST 

170 

T  r~       /LI  in      IT      l|i    IB      Al  1    A  \       A  A      T  A      i  A 

IF   (NLP .LT .NLU-NLA)  GO  TO  10 

IIA  X 

MST 

180 

a  i  i  i     n»rr     /  a  \ 

CALL  PAGE  (4) 

IIA  X 

MST 

190 

in    I  r\ 

NLA=0 

AAA  T 

MST 

200 

10 

r\  A      a  a      TV/A      1      ||  An 

DO  20  IYA=1,NCP 

IIA  X 

MST 

210 

T  1       MA  A  TV/A 

I 1=NCA+I YA 

IIA  X 

MST 

220 

20 

AO  OA  /  TV/A  \        /TAAjAA/Ti       -o   \       i    v     iiinAltl  . 

NBC ( I YA)= ( IARGS ( I 1+1 ) -1 ) /NR0W+1 

IIA  X 

MST 

230 

A  A     T  A       /  *>  A      *  A      f  a      t  t\      •»  a      a  A      A  A  »           t  im 

GO  TO  (30,40,50,60,70,80,90),  IND 

IIA  T 

MST 

240 

30 

iiin  ITT       /TAATAIT      1  "»  A  \ 

WRITE  (IPRINT, 130) 

IIA  T 

MST 

250 

AA      XA      1  A A 

GO  TO  100 

IIA  TT 

MST 

260 

40 

Ikin  T  X  A       /TAATAIT      1   4  A  \ 

WRITE  (IPRINT, 140) 

IIA  T 

MST 

270 

A  A      X  A      1  A  A 

GO  TO  100 

IIA  T 

MST 

280 

50 

Ikin  T  T  r       /THAT  JIT      ■y  f  /\  \  |||| 

WRITE  (IPRINT, 150)  MM 

IIA  T 

MST 

290 

A  A     T  A      l  A  A 

GO  TO  100 

AAA  T 

MST 

300 

60 

in  a  t  x  r~     /  t  nn  t  iit    i  /  a  \ 

WRITE  (IPRINT, 160) 

IIA  T 

MST 

310 

AA     T A      T  AA 

GO  TO  100 

MST 

320 

70 

inn  t  tt     /  t  nn  t  iit    i  t  a  \ 

WRITE  (IPRINT, 170) 

AAA  T 

MST 

330 

A  A       X  A       i  a  a 

GO  TO  100 

AAA  T 

MST 

340 

80 

T  .         /TAAAA/AIAA       *»v       1    \     1  kl  H  A  III  1 

11= (IARGS (NRA+3)-l) /NR0W+1 

AAA  X 

MST 

350 

T  A       IIA  A  dell  A 

I2=NCA*M+2 

AAA  X 

MST 

360 

mn  t  t  i-       .  t  r\  n  t  i  ■  t      •  h.  *  ^       nil     n   *  v  a  *       t  ^      1 1  n  a  /  «i  » 

WRITE  (IPRINT, 180)  NN  ,B  ( 1 2 )  ,  1 1  ,NBC  (1 ) 

IIA  X 

MST 

370 

^\    *\             <AW  ^\             A       A  A 

GO  TO  100 

IIA  X 

MST 

380 

90 

WRITE  (IPRINT, 190) 

IIA  X 

MST 

390 

100 

■  l|FN  x  T  A        /  T  f>  n  T  11  T       a  A  A  i          /linA/Tt        T        1        II  A  A  \ 

WRITE  (IPRINT, 200)   (NBC (I ) , 1=1 ,NCP) 

AAA  X 

MST 

400 

mn  t  t  ^      *  v  n  n  t  1 1         a  «  a  % 

WRITE  (IPRINT, 210) 

AAA  X 

MST 

410 

A  A         a,     ™    A         IQI   A    A           a          ||  K  A\ 

DO  110  NAGA=1,NRP 

IIA  X 

MST 

420 

1 1     a     1 1 *>*  i     hi  a  i 

NBR=NRA+NAGA 

IIA  X 

MST 

430 

*     ■            ft  ■  A    1    4  1  A        ft  ■ 

Il=NCA*M+NBR 

IIA  X 

MST 

440 

v  jk         *  a           ■  |i  yA  n.       1 1  1         a     ■  a        a     a  ■  ■  ■  j  iJr     ,  11  A  FN       III  A  It*         «    i    4>  |J 

I2=I1+(NCP-MAX0 (0 ,LCHK* (NCP-NAGA) )-l)*M 

IIA  X 

MST 

450 

1  1             f»i                 £     •      1              A    /**        d    ||  fAfc    |A.             4k                ■       h           J   1 1   A  A   III  * 

NBR=(IARGS (NBR+1)-1) /NR0W+1 

IIA  X 

MST 

460 

mn  t  v  «~      .  *  n  n  t  i  n  v     a  >b  a  v         unn      >  n  /  t  \      t      t  h      t  a  il\ 

WRITE  (IPRINT, 220)   ,NBR , (B ( I ) , 1=1 1 , 12 , M) 

AAA  X 

MST 

470 

t  r        ,  *  ii  a      ii  it      m  .        a  a      t  a      «  *a  a 

IF  (IND.NE.7)  GO  TO  110 

AAA  X 

MST 

480 

I1=I1+2*M*M 

AAA  X 

MST 

490 

V     AA               •     ft             A    "A*   A  A  *|*    A  A 

I2=I2+2*M*M 

AAA  X 

MST 

500 

WRITE  (IPRINT, 230)   (B ( I ) , 1=1 1 , 12 ,M) 

AAA  X 

MST 

510 

WRITE  (IPRINT, 210) 

MST 

520 

110 

CONTINUE 

MST 

530 

im  a     im  a    kii  n 

NLA=NLA+NLP 

540 

NRA=NRA+LCHK*NCP 

MST 

550 

120 

NCA=NCA+NCP 

MST 

560 

RETURN 

MST 

570 

C 

MST 

con 

3  0  U 

130 

FORMAT  (/1H  ,44X,31HSIMPLE  CORRELATION  COEFFICIENTS) 

MST 

590 

156 


140      FORMAT  (/1H  , 22X , 75HSIGNIFICANCE  LEVELS  OF  SIMPLE  CORRELATION  COEFMST  600 

1FICIENTS  (ASSUMING  NORMALITY))  MST  610 

150      FORMAT  (/1H  , 25X , 37HPARTI AL  CORRELATION  COEFFICIENTS  WITH,I3,26H  RMST  620 

1EMAINING  VARIABLES  FIXED)  MST  630 

160      FORMAT  (/1H  , 22X , 76HSIGNIFICANCE  LEVELS  OF  PARTIAL  CORRELATION  COEMST  640 

1FFICIENTS  (ASSUMING  NORMALITY))  MST  650 

170      FORMAT  (/1H  , 30X , 58HSPEARMAN  RANK  CORRELATION  COEFFICIENTS  (ADJUSTMST  660 

1ED  FOR  TIES))  MST  670 

180      FORMAT  (/1H  ,8X,79HSIGNIFICANCE  LEVEL  OF  QUADRATIC  FIT  OVER  LINEARMST  680 

1  FIT  BASED  ON  F  RATIO  WITH  1  AND,I5,19H  DEGREES  OF  FREED0M/1H  ,7X,MST  690 
213H(F0R  EXAMPLE, F7.4,60H  IS  THE  SIGNIFICANCE  LEVEL  OF  THE  QUADRATIMST  700 
3C  TERM  WHEN  COLUMN , 13 , 20H  IS  FITTED  TO  COLUMN , 13 , 1H ) )                       MST  710 

190      FORMAT  (/1H  , 17X , 86HC0NFIDENCE  INTERVALS  FOR  SIMPLE  CORRELATION  COMST  720 

1EFFICIENTS  (USING  FISHER  TRANSFORMATION) /30X ,68H95  PER  CENT  LIMITSMST  730 

2  BELOW  DIAGONAL,  99  PER  CENT  LIMITS  ABOVE  DIAGONAL)  MST  740 
200  FORMAT  (/1H  , 6HC0LUMN , 101 11 )  MST  750 
210  FORMAT  (1H  )  MST  760 
220  FORMAT  (1H  , 14 ,4X , 10F11 .4)  MST  770 
230      FORMAT  (1H  ,6X,10F11.4)                                                                         MST  780 

END  MST  790 


409-118  OL  -  71  -  11 
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CIIDDnilTTMP    Ml/  DHM 

Ml/  D 

1  A 
10 

L 

WCDCIflN       C    (Id              Ml/ 13  ft  N 

c  n  c  /  in 
D / 13 / / U 

MV  0 

Kir.K 

0  A 

p 
t 

DDI  IT  T  KIP    U/DTTTPM    FflD  ftMMTTAR 
KUU  1  1  NL    WK  i  1  1  LIM    r  UK    UIVIN  J.  1  AD 

11/     3 j 0 / 

RV  C 
D  T  o 

r  LA  V  T 

Ml^  0 
IVIISK 

%  A 

L 

A  A 
4U 

L 

KRONECKER  PRODUCT  OF  TWO  MATRICES  A (N 

IVIM< 

C  A 
30 

C 

Ml/  D 

L  ft 

60 

ftr<;t  four  argiimfnt^  nFFTNF 

MATRIX  A 

STARTING  POS 

AMD 
ANU 

C  T  7C 

IVllvK 

7  A 
/  0 

NEXT    FOUR  ARGUMENTS  DEFINE 

MATRIX  B 

STARTING  POS 

AND 

SIZE 

IVllsrv 

Q  A 

Li 

LAST  TWO  ARGUMENTS  INDICATE 

WHERE  RESULT 

IS  TO  BE 

STORED  D 

MVP 

OA 

COMMAND  IS: 

WINK 

i  nn 
1  u  u 

r> 
L 

MKRON  A(, ,  ++) ,R=, ,  C=, ,*B(, 

,  ++),R=, 

,  c= 

STORE 

D(, 

,  ++) 

Ml/  D 

1  1  A 

110 

c 

Ml/D 
|V1M\ 

1  0  A 
i  £  U 

l» 

Nll\l\ 

1  A 
1  J  U 

COMMON  /BLOCRC/  NRC  , RC  ( 12600 ) 

MKR 

1  4  A 
14U 

COMMON  /BLOCKD /  IARGS(IOO) ,KIND(100) ,AR6TAB(100) ,NRMAX ,NR0W,NC0L ,NMKR 

i  tin 

1ARGS,VWXYZ(8) ,NERR0R 

MKR 

1  AA 
10U 

DIMENSION  ARGS(IOO) 

MKR 

1  7  A 
1  /  U 

EQUIVALENCE  (ARGS ( 1 ), RC  (12501 ) ) 

MKR 

i  ftn 

COMMON  /SCRAT/  NS  ,NS2 , A (13500) 

MKR 

1  OA 
1  7U 

IF  (NARGS  NE  10)  CALL  ERROR 

(101 

MKR 

J=NARGS 

MKR 

0  1  A 
£  IU 

CALL  CKIND  (Jl 

MKR 

0  0  A 

IF  (J  NE  0)  CALL  ERROR  (3) 

MKR 

9  1  A 

IF   (NERROR  NE  0 1  RETURN 

MKR 

I  ARGS  ( 11  ^,-IARGS  (3  1  *  I  ARGS  (7) 

MKR 

LjU 

I ARGS  ( 12 1 -I ARGS (41  *  I ARGS  (8 ) 

MKR 

9  A  A 
£00 

J-3 

MKR 

0  7  A 
c  1  U 

CALL  MTXCHK  (Jl 

MKR 

4  OU 

IF   (J  EQ  01  GO  TO  10 

MKR 

ion 
£7U 

CALL  ERROR  (171 

UnLL     Ll\l\ul\      \      *  ) 

MKR 

^<in 

RETURN 

MKR 

1  A 

10 

NRA-TARGS (1 1 

MKR 

9  A 

J  c  u 

NCA— T  ARG<\  (4  \ 

MKR 

NRR—  T  ARG<s  ( 7  \ 

MKR 

NCR— T  ARC^ 1  ft ^ 

MKR 

•a  c  n 

kinc  i 
NUO=l 

MKR 

^  AD 

KA=1  AKuo  ( 1 ) 

MKR 

^  7n 

UU    40    1  l/A=l  ,  NLA 

MKR 

1  A— T  ARC*; ( 5 1 

Ln — XMIxU  J  \D  J 

MKR 

J  7  u 

DO  30  ICB=1,NCB 

ltil\r\ 

Ann 

HUU 

K=KA 

itii\i\ 

ai  n 

1 1  u 

DO  20  IRA=1 ,NRA 

MKR 

4?n 

T=RC(K) 

MKR 

A^n 

K=K+1 

MKR 

AAn 

L=LA 

MKR 

dsn 

DO  20  IRB=1 , NRB 

MKR 

AAn 

A(NDS)=T*RC(L) 

MKR 

A7n 

HIM 

L=L+1 

MKR 

*T  O  U 

20 

NDS=NDS+1 

MKR 

490 

30 

LA=LA+NR0W 

MKR 

500 

40 

KA=KA+NR0W 

MKR 

510 

NCR=IARGS(11) 

MKR 

->  £  w 

NCC=IARGS(12) 

MKR 

j  J  u 

NDS=1 

MKR 

KA=IARGS(9) 

MKR 

R^n 

DO  60  I=1,NCC 

MKR 

K=KA 

MKR 

JIM 

DO  50  J=1,NCR 

MKR 

580 

RC(K)=A(NDS) 

MKR 

590 

158 


NDS=NDS+1 
50  K=K+1 
60  KA=KA+NR0W 

RETURN 

END 


MKR  600 
MKR  610 
MKR  620 
MKR  630 
MKR  b40 


159 


c 
c 
c 
c 
c 
c 
c 


c 
c 
c 

10 

c 
c 
c 


c 
c 
c 

20 

c 
c 
c 
c 

70 
80 
100 


110 
120 

c 
c 
c 

130 


C 
C 


SUBROUTINE  MMULT 
VERSION  5.00 

SUBROUTINE  MMULT 

* 


MMULT 

10/  4/67 


5/15/70 


SUBROUTINE  TO  MULTIPLY  MATRICES 

GENERAL  FORMS  OF  MMULT 
MMULT  A(,)  N,K,  BY  B(() 


K,M  AND  STORE  IN  C(,) 


MMU 
MMU 
MMU 
MMU 
MMU 
MMU 
MMU 


10 
20 
30 
40 
50 
60 
70 


CHECK  TO  SEE  IF  WE  HAVE  CORRECT  NUMBER  OF  ARGUMENTS 

* 

IF(NARGS.NE.IO)  CALL  ERROR(IO) 

* 


CHECK  TO  SEE 

* 


IF  ALL  ARGUMENTS  ARE  INTEGERS 


J=NARGS 
CALL  CKIND  (J) 
IF  (J.EQ.O)  GO  TO 
CALL  ERROR  (3) 


20 


CHECK  TO  SEE 


IF  DIMENSIONS  ARE  CORRECT 


*  MMU  110 
COMMON  /SCRAT/  NS ,NS2 ,A (13500  )  MMU  120 
COMMON  /BLOCRC/  NRC , RC  ( 12600 )  MMU  130 
COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NMMU  140 

1ARGS ,VWXYZ (8) ,NERROR  MMU  150 

DIMENSION  ARGS(IOO)  MMU  160 

EQUIVALENCE  (ARGS (1) ,RC (12501) )  MMU  170 

DOUBLE  PRECISION  X,SUM  MMU  180 

DIMENSION  X(l)  MMU  190 

EQUIVALENCE  (X,A)  MMU  200 

*  MMU  210 

MMU  220 
MMU  230 
MMU  240 
MMU  250 
MMU  260 
MMU  270 
MMU  280 
MMU  290 
MMU  300 
MMU  310 
MMU  320 
MMU  330 
MMU  340 
MMU  380 
MMU  420 
MMU  430 
MMU  440 
MMU  450 
MMU  490 
MMU  500 
MMU  630 
MMU  640 
MMU  650 
MMU  660 
MMU  670 
MMU  680 
MMU  690 
MMU  700 
MMU  710 
MMU  720 
MMU  730 
MMU  740 
MMU  750 
MMU  760 
MMU  770 
MMU  780 
MMU  790 
MMU  800 
MMU  810 
MMU  820 
MMU  830 


IF(IARGS(4) .NE.IARGS(7) )  CALL  ERROR  (26) 

* 

CHECK  TO  SEE  IF  ARGUMENTS  ARE  OUT  OF  RANGE 

FIND  COLUMN  ADDRESSES 

* 

IARGS(12)=IARGS(NARGS-2) 
IARGS(ll)=IARGS(3j 
J=3 

CALL  MTXCHK  (J) 
IF  (J-l)  130,110,120 
CALL  ERROR  (3) 
RETURN 

CALL  ERROR  (17) 
RETURN 

CHECK  FOR  PREVIOUS  ERRORS 

* 

IF  (NERROR.NE.O)  RETURN 
IR0WA=IARGS(3) 
IC0LA=IARGS(4) 
IC0LB=IARGS(8) 
BEGIN  MULTIPLICATION 

ISP=1 

IBP=IARGS(5) 
DO  160  ICB=1,IC0LB 
IAP=IARGS(1) 
DO  150  IRA=1,IR0WA 


160 


IS=NS2 

MMU  840 

I A=I AP 

Illll  1     rt  r  A 

MMU  850 

I B=I BP 

lift  11  1      O  L  A 

MMU  860 

DO  140  J=1,IC0LA 

ftlftll  1     n  t  A 

MMU  870 

X(IS)=RC(IA)*RC(IB) 

ftlftll  1  AAA 

MMU  880 

I S= I S-l 

IAA1I  1  AAA 

MMU  890 

T  A       T  A      |i  n  A  III 

I A=IA+NR0W 

ftlftll  1  AAA 

MMU  900 

IB=IB+1 

ftlftll  1  ATA 

MMU  910 

140 

t\  AlIT  T  III  ir 

CONTINUE 

ftlftll  1  AAA 

MMU  920 

C 

* 

ftlftll  1     A  'i  A 

MMU  930 

A 

c 

p  A  1   1       DAIITf  UC     TA     frtDT     A  D  A  Rl  1  A  T  C      A  11  A     C  1  1  ftl 

CALL  ROUTINE  TO  SORT  PRODUCTS  AND  SUM 

ftlftll  1  AAA 

MMU  940 

c 

Illll  1       A  F  A 

MMU  950 

A  ■  1   1       CADTCftl     /  TArtl    A  Cllftlx 

CALL  SORTSM  (IC0LA,5UM) 

ftlftll  1     A  L  A 

MMU  960 

A  /  t  cn \      C  1  1  ftl 

A  ( ISP)=SUM 

ftlftll  1     A  "7  A 

MMU  970 

I SP=I SP+l 

ftlftll  1  AAA 

MMU  980 

150 

tap*     tin  i 

I AP=I AP+1 

All  11  1  AAA 

MMU  990 

160 

t  nn     t  nn    kin aiii 

IBP=IBP+NR0W 

ftlftll  11  AAA 

MMU 1000 

a 

c 

4= 

ftlftll  1  t  A  1  A 

MMU 1010 

c 

CTAOC     1  i  A  T  D  T  V  DDAIMI^T 

51  URt  MA  I R IX  PRODUL 1 

ftlftll  1  1  A  A  A 

MMU 1 0  Z  0 

c 

* 

ftlftll  1  1  A  O  A 

MMU 1030 

T  C  1 

1 5=1 

lllll  1  T   A  A  A 

MMU1040 

T  A      T  A  A  A  C  /  A  \ 

IC=IAR65 (9 ) 

ftlftll  IT  a  r  A 

MMU 1050 

A  A     "1  O  A      1      1      T  A  A  1  D 

uv  180  J=i , ILULb 

ftlftll  1  1  A  L  A 

MMU 1060 

nn     i  ^  A     T     1      T  D  Alii  A 

DO  170   1=1 , IROWA 

ftlftll  n  mn 

MMU 1070 

D  A  /  T  A  \      A  /  T  C  \ 
RL (1L)=A (15) 

Alftll  1  1   A  A  A 

MMU 1080 

T  C      TC  1 

15=15+1 

ftlftll  1  1  A  A  A 

MMU1090 

T  A      T  A  1 

IC=IC+1 

ftlftll  1  1  1  A  A 

MMU 1100 

1  ^  A 

170 

A  A  ft.1  T  T  fcl  II  C 

CONTINUE 

ftiftii  n  t  i  a 

MMU 1110 

180 

T  A        T  A       im/\  III       T  n  A  III  A 

IC=IC+NR0W-IR0WA 

A  AA  Al  1  4    n    A  A 

MMU 1120 

RETURN 

MMU1130 

END 

MMU 1140 

161 


SUBROUTINE  MOP 


MOP 


c 

VERSION    5.00  MOP 

5/15/70 

MOP 

c 

SUBROUTINE  TO  DO  MDEFINE , ADEFINE , MZERO , AZERO , MERASE , AERASE , MIDENT 

MOP 

c 

S.  PEAVY  FOR  OMNITAB  1108 

4/2/68 

MOP 

c 

COMMANDS  ARE  AS  FOLLOWS 

MOP 

c 

MOP 

c 

MDEFINE    MATRIX  IN 

R 

,  C  SIZE  N 

X 

M  TO  EQUAL  K 

MOP 

c 

i  f\rr  t  nr        a  r%  r%  a  w  t&i 

ADEFINE    ARRAY  IN 

R 

,  C  SIZE  N 

X 

M  TO  EQUAL  K 

MOP 

c 

MZERO        MATRIX  IN 

R 

,  C  SIZE  N 

X 

M 

MOP 

c 

AZERO        ARRAY  IN 

IT* 

R 

r\      <"*  T  T  r™      ft  1 

,  C  SIZE  N 

X 

M 

MOP 

c 

MERASE      MATRIX  IN 

R 

,  C  SIZE  N 

X 

M 

MOP 

c 

AERASE      ARRAY  IN 

R 

,  C  SIZE  N 

X 

M 

MOP 

c 

MIDENT      MATRIX  IN 

R 

,  C  SIZE  N 

X 

N 

MOP 

c 

MDIAGO      MATRIX  IN 

R 

,  C  SIZE  N 

X 

a  a            r  A  1  1  a   l          Tp*  A        IT"        A  ft  1        n  T    1  A  All  I  1 

M    EQUAL  TO  E  ON  DIAGONAL 

MOP 

c 

MOP 

c 

L2=l    MDEFINE .ADEFINE 

MOP 

c 

L2=2    MZERO, AZERO, MERASE, AERASE 

MOP 

c 

L2=3  MIDENT 

MOP 

c 

L2=4  MDIAGONAL 

MOP 

c 

MOP 

10 
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30 

40 
50 


10 
20 
30 
40 
50 
60 
70 
80 
90 


COMMON  /BLOCRC/  NRC , RC ( 12600 ) 


MOP  340 


COMMON  /BLOCKD/  IARGS (100) ,KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NM0P  350 
1ARGS,VWXYZ(8) ,NERROR 
DIMENSION  ARGS(IOO) 
EQUIVALENCE  (ARGS (1) ,RC  (12501) ) 
COMMON  /SCRAT/  NS ,NS2  ,  A  (13500) 
COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , ISRFLG 
DATA  ONE/1.0/, ZERO/0.0/ 
GO  TO  (10,50,60,80) ,  L2 
IF  (NARGS . NE . 5 )  CALL  ERROR  (10) 
IF  (KIND(NARGS) .NE.l)  CALL  ERROR  (3) 
IF  (NARGS. EQ. 4)  IARGS (4 )=IARGS (3 ) 
CONST=ARGS (NARGS) 
CONSTA=ARGS (NARGS) 
J=NARGS-1 
CALL  CKIND  (J) 
IF  (J.NE.O)  CALL  ERROR  (3) 
J=l 


CALL  MTXCHK  (J) 

IF  (J.NE.O)  CALL  ERROR  (17) 

IF  (NERROR.NE.O)  RETURN 

JB=IARGS(1) 

N=IARGS(3) 

K=IARGS(4) 

JA=JB 

IF  (L2.EQ.4)  GO  TO  90 

DO  40  KA=1,K 

JC=JB 

DO  30  NA=1,N 
RC(JC)=CONST 
JC=JC+1 

IF  (KA.GT.N)  GO  TO  40 

RC(JA)=CONSTA 

JA=JA+NR0W+1 

JB=JB+NROW 

RETURN 

IF (NARGS .NE .4)  CALL  ERROR  (10) 

CONST=ZERO 

CONSTA=ZERO 


MOP  360 
MOP  370 
MOP  380 
MOP  390 
MOP  400 
MOP  410 
MOP  420 
MOP  430 
MOP  440 
MOP  450 
MOP  460 
MOP  470 
MOP  480 
MOP  490 
MOP  500 
MOP  510 
MOP  520 
MOP  530 
MOP  540 
MOP  550 
MOP  560 
MOP  570 
MOP  580 
MOP  590 
MOP  600 
MOP  610 
MOP  620 
MOP  630 
MOP  640 
MOP  650 
MOP  660 
MOP  670 
MOP  680 
MOP  690 
MOP  700 
MOP  710 
MOP  720 
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J=NARGS  MOP  730 

IF  (NARGS.EQ.4)  GO  TO  20  MOP  740 

IARGS(4)=IARGS(3)  MOP  750 

J=NARGS-1  MOP  760 

GO  TO  20  MOP  770 

60        IF  (NARGS .NE .4)  CALL  ERROR  (10)  MOP  780 

CONST=ZERO  MOP  790 

CONSTA=ONE  MOP  800 

J=NARGS  MOP  810 

GO  TO  20  MOP  820 

80        J=NARGS-1  MOP  910 

IF  (NARGS. NE. 5)  CALL  ERROR(IO)  MOP  920 

GO  TO  20  MOP  930 

90        IF  (KIND(NARGS) .EQ.O)  GO  TO  110  MOP  970 

DO  100  NA=1,N  MOP  980 

RC (JB)=ARGS (NARGS)  MOP  990 

100      JB=JB+1+NR0W  M0P1000 

RETURN  M0P1010 

110      KIND(5)=0  M0P1020 

CALL  ADRESS  (5,M)  M0P1030 

IF  (M.GT.O)  GO  TO  120  M0P1040 

CALL  ERROR  (11)  M0P1050 

RETURN  M0P1060 

120      DO  130  NA=1,N  MOP1070 

A(NA)=RC(M)  M0P1080 

130      M=M+1  M0P1090 

DO  140  NA=1,N  M0P1100 

RC(JB)=A(NA)  M0P1110 

140      JB=JB+1+NR0W  MOP1120 

RETURN  M0P1130 

END  M0P1140 
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SUBROUTINE  MOVE  MOV  10 

C         VERSION    5.00         MOVE             5/15/70  MOV  20 

COMMON  /BLOCRC/  NRC,RC(12600)  MOV  30 
COMMON  /BLOCKD/  I ARGS ( 100 ) ,KIND ( 100 ) , ARGTAB ( 100 ) ,NRMAX ,NROW,NCOL , NMOV  40 

1ARGS , VWXYZ (8 ) ,NERROR  MOV  50 

DIMENSION  ARGS(IOO)  MOV  60 

EQUIVALENCE  (ARGS ( 1 ), RC ( 12501 ) )  MOV  70 

C         THIS  ROUTINE  IS  ALSO  CALLED  BLOCKTRANSFER  MOV  80 

IF  (NARGS.EQ.6)  GO  TO  50  MOV  90 

K=10  MOV  100 

10        CALL  ERROR  (K)  MOV  110 

20        RETURN  MOV  120 

30        K=20  MOV  130 

GO  TO  10  MOV  140 

40        K=ll  MOV  150 

GO  TO  10  MOV  160 

50        IARGS(9)=IARGS(1)+IARGS(3)-1  MOV  170 

IARGS(13)=IARGS(5)+IARGS(3)-1  MOV  180 

IF  (KIND(1)+KIND(3)+KIND(4)+KIND(5) .NE.O)  GO  TO  30  MOV  190 
IF  (IARGS(l) .GT.0.AND.IARGS(3) .GT .0 .AND . IARGS (5) .GT . 0 . AND . IARGS (9 ) MOV  200 

1 .LE .NROW.AND . I ARGS (13) .LE .NROW)  GO  TO  60                                             MOV  210 

K=16  MOV  220 

GO  TO  10  MOV  230 

60        IARGS(10)=IARGS(2)+IARGS(4)-1  MOV  240 

KIND(10)=0  MOV  250 

IARGS(14)=IARGS(6)+IARGS(4)-1  MOV  260 

KIND(14)=0  MOV  270 

DO  70  1=2,14,4  MOV  280 

CALL  ADRESS  (I, I ARGS  (I))  MOV  290 

IF  (IARGS (I ) )  30,40,70  MOV  300 

70        IARGS(I)=IARGS(I)-1  MOV  310 

C  MOV  320 

C         IF  MOVE  IS  UP,  IR  =  -1,  IF  DOWN,  IR  =  +1  MOV  330 

C  IF  MOVE  IS  LEFT,  IC  =  -1,  IF  RIGHT,  IC  =  +1  MOV  340 
C         DIRECTION  OF  MOVE  IS  SUCH  THAT  THE  TWO  AREAS  CAN  BE  OVERLAPPING      MOV  350 

C         AND  IT  WILL  BE  DONE  PROPERLY.  MOV  360 

C  MOV  370 

IR=ISIGN(1,IARGS(5)-IARGS(1))  MOV  380 

IC=ISIGN(1,IARGS(6)-IARGS(2))  MOV  390 

MM=IARGS(4*IR+5)+IARGS(4*IC+6)  MOV  400 

NN=IARGS(4*IR+9)+IARGS(4*IC+10)  MOV  410 

IC=IC*NROW  MOV  420 

MMM=IARGS (3 )  MOV  430 

NNN=IARGS (4)  MOV  440 

DO  90  J=1,NNN  MOV  450 

M=MM  MOV  460 

N=NN  MOV  470 

DO  80  1=1, MMM  MOV  480 

RC(N)=RC(M)  MOV  490 

M=M-IR  MOV  500 

80        N=N-IR  MOV  510 

MM=MM-IC  MOV  520 

90        NN=NN-IC  MOV  530 

GO  TO  20  MOV  540 

END  MOV  550 
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c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 


SUBROUTINE  MPROP  MPR 
VERSION  5.00  MPROP  5/15/70  MPR 
WRITTEN  FOR  OMNITAB  BY  S  PEAVY  5/  7/68  MPR 
COMMAND  IS  AS  FOLLOWS,  X=A  OR  M  DEPENDING  APROP  OR  MPROP  IS  REQUIRMPR 
I  XPROP  OF  MATRIX  (,,  ++)  NO  OF  ROWS  NO  OF  COL  ++  MPR 
INFORMATION    PRINTED    AND  NO  STORAGE  MPR 

MPR 

II  XPROP  MATRIX  (,,  ++)  SIZE  , ,  BY  ++    PROPERTIES  STORED  ++  MPR 
PROPERTIES  PRINTED  AND  STORED  MPR 

III  XPROP  MATRIX  (,,  ++)     R=(,  C=,,  PROP  ++    COL  NORMS  (,,  ++  ) 
SAME  AS  II    PLUS  STORAGE  OF  COLUMN  NORMS 

IV  XPROP     (,,  ++)  R=,(  C=/(  PROP  ++    COL  NORMS  (,,  ++)  ROW  NORMS 
SAME  AS  III  PLUS  STORAGE  OF  ROW  NORMS,  ALSO  (R+1.++)  OF  NORM 
AVERAGES  WILL  CONTAIN  GRAND  AVERAGE,  IF  X=A . 

V  XPROP  (   ,,  ++)  R=,,  C=,,  COL  NORMS (,,  ++) 

SAME  AS  III  EXCEPT    PROPERTIES  WILL  NOT  BE  STORED 

VI  XPROP  (,,  ++)     R=,,  C=,,  COL  NORMS (,,  ++)  ROW    NORMS  (,,  ++) 
SAME  AS  IV    EXCEPT    PROPERTIES  WILL  NOT  BE  STORED 
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20 
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40 
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90 


VII  SXPROP 

IF  COMMANDS  I-VI  ARE  PREFACED  WITH  AN  S  PRINTOUT 
OF  PROPERTIES  WILL  BE  SUPPRESSED 


L2  OPTIONS: 

L2=  1  MPROP: 
L2=  2  APROP: 


L2=3  SMPROP 
L2=4  SAPROP 


10 


COMMON /HEADER /NOCARD (80) , ITLE (60 ,6) , LNCNT , IPRINT ,NPAGE , I  PUNCH 
COMMON  /SCRAT/  NS  ,NS2 (A  (13500) 
COMMON  /BLOCRC/  NRC ,RC (12600) 

COMMON  /BLOCKD /  IARGS(IOO) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL , 
1ARGS,VWXYZ(8) ,NERROR 
DIMENSION  ARGS(IOO) 
EQUIVALENCE  (ARGS (1 ), RC  (12501 ) ) 
COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG 

DIMENSION  IRSLT(6) ,  ERR  (3 ) ,  IPR0P(5),  IRSLTP(ll),  IRSLTA(2,5) 

DATA  N0/3H  NO/ , IYES/3HYES/ , IBLK/3H      /,L0WRA/3H  LO/ ,L0WRB/3HWER/ , 
1PPRA/3H  UP/,IPPRB/3HPER/,IANDA/3H  AN/ , IANDB/3HD     / , IRWA , IRWB/3H 
2,3HR0W/,ICLMA,ICLMB/3HC0L,3HUMN/,IBTHH,IBTHHA/3H      ,3H    T/ , IBTHA , 
3BTHB/3HW0-,3HWAY/,N0A,N0AB/3H      ,3H  NO/ 

IF(L2.LE.2.0R.NARGS.NE.4)  GO  TO  5 

CALL  ERROR  (233) 

RETURN 

IF  (NARGS . LT .4 .OR .NARGS .GT .9)  CALL  ERROR  (10) 

L0C=IARGS(1) 

J=NARGS 

CALL  CKIND  (J) 

IF  (J.NE.O)  CALL  ERROR  (3) 

K=5 

J=l 

IF  (NARGS-5)  60,30,10 

IF  (NARGS. EQ. 6. OR. NARGS. EQ . 8)  GO  TO  40 

IS=IARGS(5) 

J=2 

K=9 


MPR  100 
MPR  110 
MPR  120 
MPR  130 
(MPR  140 
MPR  150 
MPR  160 
MPR  170 
MPR  180 
MPR  190 
MPR  200 
MPR  210 
MPR  220 
MPR  230 
MPR  240 
MPR  250 
MPR  260 
MPR  270 
MPR  280 
MPR  290 
MPR  300 
MPR  310 
MPR  320 
MPR  340 
MPR  350 
NMPR  360 
MPR  370 
MPR  380 
MPR  390 
MPR  400 
MPR  410 
IMPR  420 
MPR  430 
IMPR  440 
MPR  450 
MPR  455 
MPR  460 
MPR  465 
MPR  467 
MPR  470 
MPR  480 
MPR  490 
MPR  500 
MPR  510 
MPR  520 
MPR  530 
MPR  540 
MPR  550 
MPR  560 
MPR  570 
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30 


40 


IF  (NARGS.EQ.7)  GO  TO  20  MPR  580 

IARGS(11)=IARGS(3)  MPR  590 

I ARGS (12 )=1  MPR  600 

IARGS(10)=IARGS(9)  MPR  610 

IARGS(9)=IARGS(8)  MPR  620 

K=13  MPR  630 

J=3  MPR  640 

IF  (L2.GT.2)  IARGS(11)=IARGS(11)+1  MPR  650 

20        IARGS(5)=IARGS(6)  MPR  660 

IARGS(6)=IARGS(7)  MPR  670 

IARGS(7)=1  MPR  680 

IARGS(8)=IARGS(4)  MPR  690 

IARGS(K)=IS  MPR  700 

CALL  ADRESS  (K,KPROP)  MPR  710 

IF  (KPROP.LE.O)  CALL  ERROR  (11)  MPR  720 

GO  TO  60  MPR  730 

J=2  MPR  740 

IF  (NARGS.EQ.6)  GO  TO  50  MPR  750 

IARGS(9)=IARGS(7)  MPR  760 

IARGS(10)=IARGS(8)  MPR  770 

IARGS(11)=IARGS(3)  MPR  780 

IARGS(12)=1  MPR  790 

J =3  MPR  800 

IF  (L2.GT.2)   IARGS(11)=IARGS(11)+1  MPR  810 

50        IARGS(7)=1  MPR  820 

IARGS(8)=IARGS(4)  MPR  830 

60        CALL  MTXCHK  (J)  MPR  840 

KARGS=K  MPR  850 

IF  (J.NE.O)  CALL  ERROR  (17)  MPR  860 

IF  (NERROR.NE.O)  RETURN  MPR  870 

K=IARGS(1)  MPR  880 

IF  (L2.EQ.2.0R.L2.EQ.4)  GO  TO  110  MPR  890 

C         COMMAND  IS  MPROP  MPR  900 

C  IS  MATRIX    A  SQUARE  ONE  MPR  910 

IF  (IARGS(3) .NE.IARGS(4))  GO  TO  90  MPR  920 

C         YES  MPR  930 
CALL  INVCHK  (RC (K) , NROW, I ARGS (3 ) , A ( 100 ) , I ARGS (3 ) +1 , A , 1 , ERR , IND )      MPR  940 

KA=K  MPR  950 

M=100  MPR  960 

L=IARGS(3)  MPR  970 

DO  80  1=1, L  MPR  980 

KB=KA  MPR  990 

DO  70  J=1,L  MPR1000 

A(M)=RC(KB)  MPR1010 

KB=KB+1  MPR1020 

70        M=M+1  MPR1030 

80        KA=KA+NROW  MPR1040 

CALL  DETRNK  (A (100 ) , L , L , DET , RANK)  MPR1050 

CALL  PVTRI   (RC(K) ,NROW, IARGS (3 ) ,INDU,INDB)  MPR1060 

CALL  PROCHK  (RC (K) ,NROW, I ARGS (3 ) , I ARGS (4 ) , IPROP , A ( 1 ) , NS2 )  MPR1070 

A(30)=0.  MPR1080 

IF  (INDU.EQ.O)  A(30)=A(30)+1.0  MPR1090 

IF  (INDB.EQ.O)  A(30)=A(30)+2 .0  MPR1100 

A(19)=DET  MPR1110 

A(20)=RANK  MPR1120 

A(21)=ERR(1)  MPR1130 

A(22)=ERR(2)  MPR1140 

A(23)=ERR(3)  MPR1150 

A(24)=0.  MPR1160 
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IF  ( IPROP  (3  ) 

.  EQ 

0 ) 

A  (24) 

=1  .0 

IF  (IPROP  (3 ) 

.  EQ 

1) 

A(24) 

=2.0 

A (25)=0 . 

IF  (IPR0P(2) 

.LT 

2) 

A(25) 

=IPR0P(2)+1 

A (26 )=0 . 

IF  (IPR0P(2) 

.GT 

2) 

A(26) 

=IPR0P(2)-2 

A (27 )=0 . 

IF  (IPROP(l) 

.  EQ 

0) 

A(27) 

=1 . 

A(28)=0.0 

IF  (IPR0P(4) 

.LT 

2) 

A(28) 

=IPR0P(4)+1 

A(29)=0. 

IF  (IPR0P(5) 

.LT 

2) 

A(29) 

=IPR0P(5)+1 

GO  TO  110 

90        CALL  ORTHRV  (RC (K ) ,NROW, I ARGS (3 ) , I ARGS (4 ) , I  PROP (4 ) , A ( 1 ) ,NS2 , A ( 1 ) ) 

DO  100  1=19,31 
100  A(I)=0.0 

110      CALL  RCSUM  (RC (K) ,NR0W, I ARGS (3 ) , I ARGS (4 ) , A ( 101 ) ) 
L=IARGS(3) 

IF  (L.GT.IARGS(4))  L=IARGS(4) 

ITRACE=L 

IP0S=0 

IZER0=0 

INEG=0 

TRACE=0.0 

AMX=RC(K) 

AMN=AMX 

LA=IARGS(3)+IARGS(4) 

AVG=A(LA+102)/FL0AT(IARGS(3)*IARGS(4) ) 

ABSMX=ABS (AMX) 

ABSMN=ABS (AMN) 

ABSMNZ=ABSMN 

SSQ=0.0 

SRSQ=0.0 

SCSQ=0.0 

IF  (ABSMNZ.EQ.0.0)  ABSMNZ=1.E35 
KA=K 

DO  120  1=1 ,L 
TRACE=TRACE+RC(KA) 
120  KA=KA+NROW+l 
IN=IARGS(3) 
JK=IARGS(4) 
KA=K 
FIN-IN 
FJK=JK 

DO  200  J=1,JK 
KB=KA 

DO  190  1=1 , IN 

KC=IARGS(4)+I 

SSQ=SSQ+(RC(KB)-AVG)**2 

SCSQ=SCSQ+(RC(KB)-A(J+100)/FIN)**2 

SRSQ=SRSQ+(RC(KB)-A(KC+100)/FJK)**2 

IF  (RC (KB) )  130,140,150 
130      I NEG=I NEG+1 

GO  TO  160 
140  IZER0=IZER0+1 

GO  TO  160 
150  IP0S=IP0S+1 

160      IF  (AMX .GT .RC (KB) )  GO  TO  170 
AMX=RC (KB) 


MPR1170 
MPR1180 
MPR1190 
MPR1200 
MPR1210 
MPR1220 
MPR1230 
MPR1240 
MPR1250 
MPR1260 
MPR1270 
MPR1280 
MPR1290 
MPR1300 
MPR1310 
MPR1320 
MPR1330 
MPR1340 
MPR1350 
MPR1360 
MPR1370 
MPR1380 
MPR1390 
MPR1400 
MPR1410 
MPR1420 
MPR1430 
MPR1440 
MPR1450 
MPR1460 
MPR1470 
MPR1480 
MPR1490 
MPR1500 
MPR1510 
MPR1520 
MPR1530 
MPR1540 
MPR1550 
MPR1560 
MPR1570 
MPR1580 
MPR1590 
MPR1600 
MPR1610 
MPR1620 
MPR1630 
MPR1640 
MPR1650 
MPR1660 
MPR1670 
MPR1680 
MPR1690 
MPR1700 
MPR1710 
MPR1720 
MPR1730 
MPR1740 
MPR1750 
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170 
180 


185 
190 
200 


210 
220 

230 

240 
250 


260 
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A ( 16 )=bbbU 

MPR  7  310 
mr  iVb^iv 

A ( 17 ) =A ( LA+104 ) 

MPR2320 

A(18)=A(17)/FL0AT(IARGS(3)*IAR6S(4) ) 

MPR2330 
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IF  (L2 .6E.3)  GO  TO  570 

MPR2340 

CALL  PAGE  (4) 

MPR2350 

IF  (L2.NE.1)  GO  TO  370 

MPR2360 

WRITE  (IPRINT(640)  I ARGS (3 ) , IARGS (4 ) , LOC , IARGS  (2 ) 

MPR2370 

IF  (MOD (NARGS ,2) .EQ  .0)  GO  TO  270 

MPR2380 

WRITE  (IPRINT,650)  IARGS (KARGS) 

MPR2390 

270 

WRITE  (IPRINT,660)  ITRACE  ,  (A(I)  ,1=1,7) , IPOS , IZERO , INEG , (A(I) , 1=11 ,MPR2400 

116) 

MPR2410 

WRITE  (IPRINT,670)  A(17),A(18) 

MPR2420 

WRITE  (IPRINT,680) 

MPR2430 

IF  (IARGS(3) .NE.IARGS(4))  GO  TO  390 

MPR2440 

IRANK=A(20)+.5E-5 

MPR2450 

WRITE  (IPRINT,690)  A ( 19 ) , IRANK , (A ( I ) , 1=21 , 23 ) 

MPR2460 

DO  280  1=1,6 

MPR2470 

IRSLT (I )=IYES 

MPR2480 

IRSLTP(I)=A(I+23) 

MPR2490 

IF  (A(I+23) .EQ.O.)  IRSLT(I)=NO 

MPR2500 

280 

CONTINUE 

MPR2510 

C 

SET  IRSLT (I ) ,1=1,6    FOR  YES  OR  NO.  ALSO  A ( I ) , 1=24 ,29 

MPR2520 

DO  290  1=1,5 

MPR2530 

IRSLTA(1,I)=IBLK 

MPR2540 

290 

IRSLTA(2,I)=IBLK 

MPR2550 

IRSLTA(1,3)=N0A 

MPR2560 

IRSLTA(2,3)=N0AB 

MPR2570 

IF  (INDU.NE.O .AND.INDB.NE.O)  GO  TO  320 

MPR2580 

IF  (INDU.NE.O)  GO  TO  310 

MPR2590 

IF  (INDB.EQ.O)  GO  TO  300 

MPR2600 

IRSLTA(1,1)=IPPRA 

MPR2610 

IRSLTA(2,1)=IPPRB 

MPR2620 

GO  TO  320 

MPR2630 

300 

IRSLTA(1,1)=IPPRA 

MPR2640 

IRSLTA(2,1)=IPPRB 

MPR2650 

IRSLTA(1,2)=IANDA 

MPR2660 

IRSLTA(2,2)=IANDB 

MPR2670 

310 

IRSLTA(1,3)=L0WRA 

MPR2680 

IRSLTA(2,3)=L0WRB 

MPR2690 

320 

IRSLTA(1,5)=N0A 

MPR2700 

IRSLTA(2,5)=N0AB 

MPR2710 

IF  ( ISTOCR+ISTCHC .EQ . 3 )  GO  TO  340 

MPR2720 

IF  (ISTOCR.EQ.O)  GO  TO  330 

MPR2730 

IRSLTA(1,5)=IRWA 

MPR2740 

IRSLTA(2,5)=IRWB 

MPR2750 

GO  TO  350 

MPR2760 

330 

IF  (ISTCHC.EQ.O)  GO  TO  350 

MPR2770 

IRSLTA(1,5)=ICLMA 

MPR2780 

IRSLTA(2,5)=ICLMB 

MPR2790 

GO  TO  350 

MPR2800 

340 

IRSLTA(1,4)=IBTHH 

MPR2810 

IRSLTA(2,4)=IBTHHA 

MPR2820 

IRSLTA(1,5)=IBTHA 

MPR2830 

IRSLTA(2,5)=IBTHB 

MPR2840 

350 

IRSLTP(7)=A(30) 

MPR2850 

IRSLTP(8)=A(31) 

MPR2860 

WRITE  (IPRINT,700)   ( IRSLT ( I ) , IRSLTP ( I ) , 1=1 , 6 ) 

MPR2870 

WRITE  (IPRINT.710)   ( ( IRSLTA ( I , J ) , 1=1 , 2 ) , J=l , 3 ) , IRSLTP (7 ) 

( (IRSLTA(MPR2880 

1I,J),I=1,2),J=4,5),IRSLTP(8) 

MPR2890 

DO  360  1=1,2 

MPR2900 

360 

WRITE  (IPRINT,720) 

MPR2910 

WRITE  (IPRINT,730) 

MPR2920 
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DO  620  1=1 , JK  MPR3520 
RC (KA)=A ( 1+100 ) /ANRMX  MPR3530 
620      KA=KA+NROW  MPR3540 
IF   (NARGS.LT.8)  RETURN  MPR3550 
KA=IARGS(9)  MPR3560 
ANRMX=I ARGS (4 )  MPR3570 
KB=JK+101  MPR3580 
DO  630  1=1, IN  MPR3590 
RC(KA)=A(KB) /ANRMX  MPR3600 
KA=KA+1  MPR3610 
630      KB=KB+1  MPR3620 
IF  (L2.GT.2)  RC(KA)=AVG  MPR3630 
RETURN  MPR3640 
C  MPR3650 
640      FORMAT   (1H0 , 39X , 14HPR0PERTIES  OF   ,13, 3H  X  ,I3,27H  MATRIX  STARTING  MPR3660 
1L0CATI0N   ( , 13 , 1H , , 13 ,1H)  )  MPR3670 
650      FORMAT   (23X , 3HC0L , 1 7 )  MPR3680 
660      FORMAT  (3 OX , 7HGENERAL/23X , 1HR/23X , 9H1  TRACE  ( , 13 , 13H  VALUES  USED ) , MPR3690 
17X,1PE15 .6/23X,32H2  TRACE  NO.  2  , E15 . 6 / /23X , 32H3MPR3700 

2  MAXIMUM  ELEMENT  , E15 . 6 /23X , 20H4  MINUMUM  ELEMENT  ,MPR3710 

3  12X  ,E15.6/23X,32H5  MAXIMUM  ELEMENT  IN  ABS  VALUE  ,E15 . 6 /23XMPR3720 
4,32H6  MINUMUM  ELEMENT  IN  ABS  VALUE  , E15 . 6 /23X , 32H7  MIN  NON-ZERO  EMPR3730 
5LEM  IN  ABS  VAL  ,E15 . 6 / /23X , 32H8  NUMBER  OF  POSITIVE  ELEMENTS  ,10MPR3740 
6X,I5/,23X,32H9  NUMBER  OF  ZERO  ELEMENTS  , 10X , 1 5 /22X , 33H10  NUMMPR3750 
7BER  OF  NEGATIVE  ELEMENTS  , 10X , 15 / /22X , 33H11  SUM  OF  TERMS  MPR3760 
8  ,E15.6/22X,33H12  AVERAGE  ,E15 .6/22MPR3770 
9X,33H13  SUM  OF  SQUARES  , E15 . 6 /22X , 33H14  SUM  OF  SQUAMPR3780 
$RES  ABOUT  MEAN  , E15 . 6 /22X , 33H15  WITHIN  ROWS  SUM  OF  SQUARES  MPR3790 
$,E15.6/22X,33H16  WITHIN  COLS  SUM  OF  SQUARES        ,E15.6)  MPR3800 

670      FORMAT  (22X,33H17  SUM  OF  ABSOLUTE  VALUES  , 1PE15 . 6 /22X , 33H18MPR3810 

1  AVERAGE  OF  ABSOLUTE  VALUES        ,E15.6)  MPR3820 

680      FORMAT  (1H0 , 29X , 8HSPECIFIC/ )  MPR3830 

690      FORMAT  (22X,33H19  DETERMINANT  , 1PE15 . 6 /22X , 33H18MPR3840 

1  RANK  ,7X,I8/30X(5HN0RMS/22X,33H21  SQ  R00MPR3850 

2T  OF  SUM  OF  B(I ,J)**2  , E15 . 1 /22X , 33H22  N*MAX (B (I , J ) )  MPR3860 
3  ,E15.1/22X/33H23  MAX  VAL  OF  ROW  SUM  ,E15.1)  MPR3870 

700      FORMAT  ( 1H0 , 21X , 32H24  NORMALITY  , 13X , A3 , 2H* ( , i 1MPR3880 

1,1H)/22X,33H25  SYMMETRY  , 12X , A3 , 2H* ( , 1 1 , 1H) /2MPR3890 

22X,33H26  SKEW  SYMMETRY  , 12X , A3 , 2H* ( , 1 1 , 1H ) /22X , 33HMPR3900 

327  DIAGONALITY  , 12X , A3 , 2H* ( , 1 1 , 1H ) /22X , 33H28  0RTMPR3910 

4H0G0NALITY:     A/A=I  , 12X , A3 , 2H* ( , I 1 , 1H ) /22X , 2H29 , 17X , 19HA / AMPR3920 

5=DIAG0NAL  MATRIX , 7X , A3 , 2H* ( , 1 1 , 1H ) / / )  MPR3930 

710  FORMAT (22X,13H30  TRIANGULAR , 2 OX ,3 A3 ,A1,2A3,3H**(,I1,1H)/22X,33H31  MPR3940 
1ST0CHASTIC  (R  AND/OR  C  SUMS=1 ) ,3X ,4A3 ,4H*** ( , 1 1 , 1H ) )  MPR3950 

720      FORMAT  (1H  )  MPR3960 

730  FORMAT  (9X,79H*  IF  ANSWER  IS  YES,  (R,C)=1  OR  2.  (1,  IF  EXACT;  2,  MPR3970 
1IF  TOLERANCE  IS  SATISFIED .) /11X , 25HI F  ANSWER  IS  NO,  (R ,C)=0 . / /8X , 1MPR3980 
20HTRIANGULAR/8X,69H**  (R,C)=0,IF  ANSWER  IS  NO;  (R,C)=1,  IF  UPPER  PMPR3990 
3ART  OF  MATRIX  IS  ZERO ; /11X , 74H (R ,C )=2 ,  IF  LOWER  PART  IS  ZERO;  (R,CMPR4000 
4)=3,  IF  ALL  OFF  DIAGONAL  ELEMENTS  =  0 . / /7X , 10HSTOCHASTIC/7X , 75H***MPR4010 

5  (R,C)=0,  IF  MATRIX  IS  NOT  STOCHASTIC;   (R,C)=1,  IF  SUM  OF  EACH  ROWMPR4020 

6  =  1;  /11X,75H(R,C)=2,  IF  SUM  OF  EACH  C0LUMN=1;   (R,C)=3,  IF  SUM  0FMPR4030 

7  EACH  ROW  AND  C0LUMN=1 . )  MPR4040 
740      FORMAT  ( 1H0 , 39X , 14HPR0PERTIES  OF  ,I3,3H  X  ,I3,26H  ARRAY  STARTING  LMPR4050 

10CATI0N  (,I3,1H,,I3,1H))  MPR4060 
750      F0RMAT(22X,32H26  ORTHOGONALITY:     A/A=I  , 9X , 2A3 , 2H* ( , 1 1 , 1H ) /MPR4070 

1  22X,2H27,17X,19HA/A=DIAG0NAL  MATRIX , 3X2A3 , 2H* (, 1 1 , 1H) )  MPR4080 
760      FORMAT  (9X,86H*  (R,C)=0,  IF  MATRIX  IS  NOT  ORTHOGONAL;   (R,C)=1  OR  2MPR4090 

1  IF  MATRIX  IS  ORTHOGONAL  ROW  WI SE ; /11X , 97H (R , C )=3  OR  4,  IF  MATRIX  MPR4100 
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2IS  ORTHOGONAL  COLUMN  WISE .   (   (R,C)=I,  IF  1=1  OR  3  ORTHOGONALITY  ISMPR4110 
3  EXACT; /11X,50HF0R  1=2  OR  4  RELATIVE  WITHIN  ERROR  BOUND  OF  . IE . 6 ) ) MPR4120 
END  MPR4130 
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SUBROUTINE  MRAISE  MR A  10 

C         VERSION    5.00          MRAISE          5/15/70  MR  A  20 

C         *  MR A  30 

C          SUBROUTINE  TO  RAISE  A  MATRIX  TO  A  POWER                    9/13/67  MR  A  40 

C                   GENERAL  FORMS  OF  MRAISE  MR A  50 

C                          MRAISE  A  ( , )  N ,N  TO  M  POWER  AND  STORE  IN    C(,)  MR A  60 

C                          M  MAY  BE  INTEGER  OR  REAL  MR A  80 

C                          IF  M=0    C=IDENTITY  MATRIX  MR A  90 

C                          IF  M=l    C=A  MR A  100 

C         *  MR A  110 

COMMON  /BLOCRC/  NRC , RC ( 12600 )  MR  A  120 

COMMON  /BLOCKO/  IARGS (100 ), KIND ( 100 ), ARGTAB ( 100 ) ,NRMAX , NROW, NCOL , NMRA  130 

1ARGS ,VWXYZ (8 ) ,NERROR  MRA140 

DIMENSION  ARGS(IOO)  MR A  150 

EQUIVALENCE  (ARGS (1) ,RC (12501) )  MRA160 

COMMON  /SCRAT/  NS ,NS2 , A (13500 )  MR A  170 

DOUBLE  PRECISION  X,SUM  MR A  180 

DIMENSION  X(l)  MRA  190 

EQUIVALENCE  (X,A)  MRA  200 

C         *  MRA  210 

C         CHECK  NUMBER  OF  ARGUMENTS  MRA  220 

C         *  MRA  230 

IF (NARGS .NE .7 )  CALL  ERROR  (10)  MRA  240 

C         *  MRA  250 

C         CHECK  TO  SEE  IF  ALL  ARGUMENTS  ARE  INTEGER  MRA  260 

C         *  MRA  270 

J=NARGS  MRA  280 

CALL  CKIND  (J)  MRA  290 

IF  (J.EQ.O)  GO  TO  20  MRA  300 

IF  (KIND (NARGS-2 ) .NE.O)  GO  TO  10  MRA  310 

CALL  ERROR  (3)  MRA  320 

GO  TO  20  MRA  330 

10        I ARGS (NARGS-2 )=ARGS (NARGS-2)  MRA  340 

C         *  MRA  350 

C         CHECK  TO  SEE  IF  M  (POWER)  IS  NEGATIVE  MRA  360 

C         *  MRA  370 

20        IF  ( IARGS (NARGS-2 ) .LT.O)  CALL  ERROR  (3)  MRA  380 

C         *  MRA  390 

C         CHECK  TO  SEE  IF  DIMENSIONS  ARE  CORRECT  MRA  400 

C         *  MRA  410 

IF  (IARGS(3) .NE.IARGS(4) )  CALL  ERROR  (3)  MRA  430 

C         *  MRA  440 

C         CHECK  TO  SEE  IF  ARGUMENTS  ARE  OUT  OF  RANGE  MRA  450 

C         *  MRA  460 

30        NP0W=IARGS(NARGS-2)-l  MRA  470 

40        IARGS(5)=IARGS(NARGS-1)  MRA  500 

IARGS(6)=IARGS(NARGS)  MRA  510 

IARGS(7)=IARGS(3)  MRA  520 

IARGS(8)=IARGS(4)  MRA  530 

J=2  MRA  540 

CALL  MTXCHK  (J)  MRA  550 

IF  (J-l)  70,50,60  MRA  560 

50        CALL  ERROR  (3)  MRA  570 

RETURN  MRA  580 

60        CALL  ERROR  (17)  MRA  590 

RETURN  MRA  600 

C         *  MRA  610 

C         CHECK  TO  SEE  IF  PREVIOUS  ERRORS  MRA  620 

C         *  MRA  630 
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IR=IR+NR0W 

MRA1230 

250 

CONTINUE 

MRA1240 

DO  270  J=l , ISIZE 

MRA1250 

IX=IXP 

MRA1260 

IM=IMP 

MRA1270 

DO  260  JP=1 , ISIZE 

MRA1280 

X(IM)=A(IX)*A(IC) 

MRA1290 

IM=IM-1 

MRA1300 

IX=IX-1 

MRA1310 

IC=IC+1 

MRA1320 

260 

CONTINUE 

MRA1330 

CALL  SORTSM  (ISIZE , SUM) 

MRA1340 

RC(ISAV)=SUM 

MRA1350 

ISAV=ISAV+NROW 

MRA1360 

270 

CONTINUE 

MRA1370 

ISAVP=ISAVP+1 

MRA1380 

IRP=IRP+1 

MRA1390 

280 

CONTINUE 

MRA1400 

RETURN 

MRA1410 

END 

MRA1420 
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SUBROUTINE  MSCROW  MSC  10 

C         VERSION    5.00         MSCROW         5/15/70  MSC  20 

COMMON  /BLOCRC/  NRC ,RC  (12600)  MSC  30 
COMMON  /BLOCKD/  I ARGS (100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL ,NMSC  40 

1ARGS , VWXYZ (8 ) ,NERROR  MSC  50 

DIMENSION  ARGS(IOO)  MSC  60 

EQUIVALENCE  (ARGS (1) ,RC  (12501) )  MSC  70 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , ISRFLG  MSC  80 

C           SUBROUTINE  BY  CARLA  MESSINA  221.04  JUNE  1967                            MSC  90 

C         TYPE  1  IS             PARSUM  OF  COL  ++  ,  STORE  IN  COL  ++  MSC  100 

C  TYPE  2  IS  PARPRODUCT  OF  COL  ++,  STORE  IN  COL  ++  MSC  110 
C         TYPE  3  IS             ROOT  MEAN  SQUARE           RMS  OF  COL  ++,  STORE  IN  COL  MSC  120 

C         TYPE  4  IS             AVERAGE  OF  COL  ++,  STORE  IN  COL  ++  (DOWN  TO  NMSC  130 

C         TYPE  5  IS             SUM  COL  ++,  STORE  IN  COL  ++       (DOWN  TO  NRMAX)  MSC  140 

C                               SUM  COL  ++  FROM  ROW  , ,  TO  ROW  ,  ,  STORE  IN  COL  ++  MSC  150 

C  SUM  COL  ++    FROM  ROWS  NUMBERED    , ,  ETC  STORE  MSC  160 

C         THE  THREE  TYPES  OF  SUM  ARE  IDENTIFIED  BY  THE  NO.  OF  NARGS  =2,3  ANDMSC  170 

ELEM=0.0  MSC  180 

IF  (NARGS-2 )  10,40,40  MSC  190 

10        K=10  MSC  200 

20        CALL  ERROR  (K)  MSC  210 

30        RETURN  MSC  220 

40        CALL  ADRESS  (1,J1)  MSC  230 

IF  (Jl)  50,50,60  MSC  240 

50        K=3  MSC  250 

GO  TO  20  MSC  260 

60        CALL  ADRESS  (NARGS, J2)  MSC  270 

IF  (J2)  50,50,70  MSC  280 

70        IF  (NARGS-3)  210,80,80  MSC  290 

80        IF  (L2-5)  10,90,10  MSC  300 

90        NARG1=NARGS-1  MSC  310 

DO  110  I=2,NARG1  MSC  320 

IF  (KIND (I ) .NE.O)  GO  TO  130  MSC  330 

IF  (IARGS(I))  130,130,100  MSC  340 

100      IF  (IARGS(I)-NROW)  110,110,130  MSC  350 

110      CONTINUE  MSC  360 

IF  (NERROR.NE.O)  GO  TO  30  MSC  370 

IF  (NARGS-4 )  120,120,180  MSC  380 

C  MSC  390 

C                SUM  FROM  ROW  , ,  TO  ROW  ,  ,  MSC  400 

C  MSC  410 

120      IF  (IARGS(2)-IARGS(3) )  140,140,130  MSC  420 

130      I=IARGS(2)  MSC  430 

IARGS(2)=IARGS(3)  MSC  440 

IARGS(3)=I  MSC  450 

140      IF  (NRMAX)  150,150,160  MSC  460 

150      K=9  MSC  470 

GO  TO  20  MSC  480 

160      J=J1+IARGS(2)  MSC  490 

ELEM=ELEM+RC ( J-l )  MSC  500 

IARGS(2)=IARGS(2)+1  MSC  510 

IF  (IARGS(2)-IARGS(3))  160,160,170  MSC  520 

170      CALL  VECTOR  (ELEM, J2)  MSC  530 

GO  TO  30  MSC  540 

180      IF  (NRMAX)  150,150,190  MSC  550 

C  MSC  560 

C               SUM  DISCRETE  ROWS  MSC  570 

C  MSC  580 

190      DO  200  I=2,NARG1  MSC  590 
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J=J 1  +  IARGS ( I ) 

MSC 

600 

200 

ELEM=ELEM+RC ( J-l ) 

MSC 

610 

GO  TO  170 

MSC 

620 

210 

IF  (NERROR.NE.O)  GO  TO  30 

MSC 

630 

IF   (NRMAX)  150,150,220 

MSC 

640 

220 

FNRMAX=NRMAX 

MSC 

650 

C 

MSC 

660 

C 

PARSUM,  PARPROOUCT 

MSC 

670 

C 

MSC 

680 

IF   (L2-3)  230,260,280 

MSC 

690 

230 

J=L2-1 

MSC 

700 

RC(J2)=RC(J1) 

MSC 

710 

IF  (NRMAX. EQ.l)  GO  TO  30 

MSC 

720 

00  250  1=2 , NRMAX 

MSC 

730 

J1=J1+1 

MSC 

740 

J2=J2+1 

MSC 

750 

IF  (J.EQ.O)  GO  TO  240 

MSC 

760 

RC(J2)=RC(J2-1)*RC(J1) 

MSC 

770 

GO  TO  250 

MSC 

780 

240 

RC(J2)=RC(J2-1)+RC(J1) 

MSC 

790 

250 

CONTINUE 

MSC 

800 

GO  TO  30 

MSC 

810 

C 

MSC 

820 

C 

RMS 

MSC 

830 

C 

MSC 

840 

260 

DO  270  1=1, NRMAX 

MSC 

850 

J=J1+I 

MSC 

860 

270 

ELEM=ELEM+RC(J-1)**2 

MSC 

870 

ELEM=FSQRT (ELEM/FNRMAX) 

MSC 

880 

GO  TO  170 

MSC 

890 

C 

MSC 

900 

C 

AVERAGE,  SUM  ENTIRE  COLUMN 

MSC 

910 

C 

MSC 

920 

280 

DO  290  1=1, NRMAX 

MSC 

930 

J=J1+I 

MSC 

940 

290 

ELEM=ELEM+RC ( J-l ) 

MSC 

950 

IF   (L2-5)  300,170,170 

MSC 

960 

300 

ELEM=ELEM/FNRMAX 

MSC 

970 

GO  TO  170 

MSC 

980 

END 

MSC 

990 
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SUBROUTINE  MTRIAN  MTR  10 

VERSION    5.00         MTRIAN         5/15/70  MTR  20 

MTRIAN    SUBROUTINE  FOR  OMNITAB    11/27/67    BY  S  PEAVY  MTR  30 

MTR  40 

TRI ANGULARIZATION  OF  NON-SINGULAR,  REAL  SYMMETRIC  MATRIX                  MTR  50 

A=TT i     LOWER  TRINGLE  IS  COMPUTED  MTR  60 

COMMAND  IS:  MTR  70 

MTRIAN    A(,,  ++),R=,,  C=, ,  STORE  T  IN  (,,  ++)                                     MTR  80 

OR  MTR  90 

MTRIAN    A(,(  ++),R=,,  C=,  ,  STORE  T  IN(,(  ++)  AND  T  INVERSE  (,,  ++)MTR  100 

THE  UPPER  TRIANGLE  IS  SET  =  0 .  MTR  110 

MTR  120 

COMMON  /SCRAT/  NS , NS2 , A  ( 13500 )  MTR  130 

COMMON  /BLOCRC/  NRC  , RC  ( 12600 )  MTR  140 
COMMON  /BLOCKD/  IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NMTR  150 

1ARGS ,VWXYZ (8) ,NERROR  MTR  160 

DIMENSION  ARGS(IOO)  MTR  170 

EQUIVALENCE  (ARGS ( 1 ), RC  (12501 ) )  MTR  180 

DIMENSION  X(2)  MTR  190 

DOUBLE  PRECISION  X,SUM  MTR  200 

EQUIVALENCE  (X,A)  MTR  210 

KRR=7  MTR  220 

KRRA=7  MTR  230 

KRRB=7  MTR  240 

KRRC=7  MTR  250 

J=2  MTR  260 

IF  (NARGS . EQ . 6  .OR . NARGS  . EQ . 8 )  GO  TO  10  MTR  270 

CALL  ERROR  (10)  MTR  280 

RETURN  MTR  290 

IF  (IARGS(3) .EQ.IARGS(4))  GO  TO  20  MTR  300 

CALL  ERROR  (KRR)  MTR  310 

RETURN  MTR  320 

IF  (NARGS. EQ. 6)  GO  TO  30  MTR  330 

J=3  MTR  340 

IARGS(9)=IARGS(7)  MTR  350 

IARGS(10)=IARGS(8)  MTR  360 

IARGS(11)=IARGS(3)  MTR  370 

IARGS(12)=IARGS(4)  MTR  380 

IARGS(7)=IARGS(3)  MTR  390 

IARGS(8)=IARGS(4)  MTR  400 

CALL  MTXCHK  (J)  MTR  410 

IF  (J-l)  60,40,50  MTR  420 

CALL  ERROR  (3)  MTR  430 

RETURN  MTR  440 

CALL  ERROR  (17)  MTR  450 

RETURN  MTR  460 

IF  (NERROR.NE.O)  RETURN  MTR  470 

IR=IARGS(3)  MTR  480 

IRM=IR-1  MTR  490 

K=IARGS(1)  MTR  500 

DO  70  1=1, IR  MTR  510 

IF  (RC(K) .GT.O.O)  GO  TO  70  MTR  520 
***  ERRA  -MATRIX  CAN  NOT  BE  TRIANLIZED  SINCE  ONE  OF  THE  TERMS  ON    MTR  530 

THE  DIAG.  IS  ZERO  OR  LESS.  MTR  540 

CALL  ERROR  (KRRA)  MTR  550 

RETURN  MTR  560 

K=K+1+NR0W  MTR  570 

K=IARGS(1)  MTR  580 

CALL  SYMV  (RC(K) ,NROW,IR,M)  MTR  590 
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80 


90 


100 


110 


120 

130 
140 


IF   (M.LE.l)  GO  TO  80 

MTR  600 

***  NON-SYMMETRIC  MATRIX 

MTR  610 

CALL  ERROR  (KRRC) 

MTR  620 

RETURN 

MTR  630 

M=2 

MTR  640 

A(1)=FSQRT(RC(K) ) 

MTR  650 

K=K+1 

MTR  660 

DO  90  1=2 ,IR 

MTR  670 

A(M)=RC(K) /A(l) 

MTR  680 

K=K+1 

MTR  690 

M=M+1 

MTR  700 

KA=IARGS(1) 

MTR  710 

KB=KA+NR0W+1 

MTR  720 

MA=2 

MTR  730 

DO  140  1=2, IR 

MTR  740 

MB=MA 

MTR  750 

L=NS2-1 

MTR  760 

X(NS2)=RC(KB) 

MTR  770 

M=(I-1)*IR+I 

MTR  780 

11=1-1 

MTR  790 

DO  100  J=l , 1 1 

MTR  800 

X(L)=-(A(MB)**2) 

MTR  810 

L=L-1 

MTR  820 

MB=MB-IR 

MTR  830 

CALL  SORTSM  (I, SUM) 

MTR  840 

IF  (SUM. GT. 0.0)  GO  TO  110 

MTR  850 

***  ERRB-LEADING  SUBMATRIX  IS  SINGULAR 

MTR  860 

CALL  ERROR  (KRRB) 

MTR  870 

RETURN 

MTR  880 

S=SUM 

MTR  890 

S=FSQRT(S) 

MTR  900 

A(M)=S 

MTR  910 

M=M+1 

MTR  920 

IF  (I.EQ.IR)  GO  TO  140 

MTR  930 

IP=I+1 

MTR  940 

KC=KB+1 

MTR  950 

DO  130  J=IP,IR 

MTR  960 

X(NS2)=RC(KC) 

MTR  970 

KC=KC+1 

MTR  980 

L=NS2-1 

MTR  990 

MC=J 

MTR1000 

MD=I 

MTR1010 

DO  120  JJ=1,II 

MTR1020 

X(L)=-A(MC)*A(MD) 

MTR1030 

MC=MC+IR 

MTR1040 

MD=MD+IR 

MTR1050 

L=L-1 

MTR1060 

CALL  SORTSM  (I, SUM) 

MTR1070 

A(M)=SUM/S 

MTR1080 

M=M+1 

MTR1090 

MA=MA+IR+1 

MTR1100 

KB=KB+NR0W+1 

MTR1110 

K=IARGS(5)-1 

MTR1120 

KB=IARGS(5) 

MTR1130 

DO  180  1=1 , IR 

MTR1140 

KA=K+I 

MTR1150 

M=(I-1)*IR+I 

MTR1160 

KC=KB 

MTR1170 

DO  150  J=I,IR 

MTR1180 
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RC(KA)=A(M) 
KA=KA+1 
150  M=M+1 

IF  (I.EQ.l)  GO  TO  170 
11=1-1 

DO  160  J=l , 1 1 

RC(KC)=0.0 
160  KC=KC+1 
170  KB=KB+NROW 
180  K=K+NROW 

IF  (NARGS.EQ.6)  RETURN 

KC=IARGS(5) 

DO  210  1=1 , IR 

M=(I-1)*IR+I 

A(M)=1.0/RC(KC) 

IF  (I .EQ.IR)  GO  TO  210 

M=M+1 

IP=I+1 

KB=KC+NR0W+1 
JC=1 

DO  200  J=IP,IR 
KA=KC+J-I 
MA=(I-1)*IR+I 
L=NS2 

DO  190  JA=1,JC 
X(L)=RC(KA)*A(MA) 
MA=MA+1 
KA=KA+NROW 
190  L=L-1 

CALL  SORTSM  (JC,SUM) 
S=SUM 

A(M)=-S/RC(KB) 

KB=KB+NR0W+1 

M=M+1 
200  JC=JC+1 
210  KC=KC+NR0W+1 

K=IARGS(9)-1 

KB=IARGS(9) 

DO  250  1=1 , IR 

KA=K+I 

W=(I-1)*IR+I 
KC=KB 

DO  220  J=I,XR 
RC(KA)=A(M) 
KA=KA+1 
220  W=M+1 

IF  (I.EQ.l)  GO  TO  240 
11=1-1 

DO  230  J=1,II 

RC(KC)=0. 
230  KC=KC+1 
240  KB=KB+NROW 
250  K=K+NROW 

RETURN 

END 


MTR1190 

MTR1200 

MTR1210 

MTR1220 

MTR1230 

MTR1240 

MTR1250 

MTR1260 

MTR1270 

MTR1280 

MTR1290 

MTR1300 

MTR1310 

MTR1320 

MTR1330 

MTR1340 

MTR1350 

MTR1360 

MTR1370 

MTR1380 

MTR1390 

MTR1400 

MTR1410 

MTR1420 

MTR1430 

MTR1440 

MTR1450 

MTR1460 

MTR1470 

MTR1480 

MTR1490 

MTR1500 

MTR1510 

MTR1520 

MTR1530 

MTR1540 

MTR1550 

MTR1560 

MTR1570 

MTR1580 

MTR1590 

MTR1600 

MTR1610 

MTR1620 

MTR1630 

MTR1640 

MTR1650 

MTR1660 

MTR1670 

MTR1680 

MTR1690 

MTR1700 

MTR1710 

MTR1720 

MTR1730 
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c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 


10 

20 
30 


SUBROUTINE  MTXCHK  (J) 

VERSION    5.00  MTXCHK  5/15/70 

S  PEAVY  FOR  OMNITAB  10/24/67 

J  AS  INPUT  =  NO  OF  MATRICES  TO  BE  CHECKED 

IARGS(l)  ,  IARGS(5)  IARGS (4* (J-l ) +1 ) 

IARGS(2)  ,  IARGS  (6)  ,  IARGS  (4*  (J-D+2) 

LARGS (3),  IARGS(7),  IARGS (4* (J-l )+3 )  NO.  OF  ROWS 

IARGS(4),  IARGS(8)  IARGS (4* (J-l ) +4 )     NO  OF  COLUMNS 


STARTING  ROW  OF  MAT 
STARTING  COLUMN  OF  MAT 


MCK 
MCK 
MCK 
MCK 
MCK 
MCK 
MCK 
MCK 
MCK 


10 
20 
30 
40 
50 
60 
70 
80 
90 


UPON  RETURN 

J=0    IF    ALL  MATRICES  ARE  IN  WORK  SHEET 
AND 

IARGS(l) ,IARGS(5) ,  IARGS (4* (J-l )+l )  WILL  CONTAIN  STARTING 

ADDRESS  OF  MATRIX 
J  GT    ZERO    IF    MATRIX  IS  NOT  IN  WORK  SHEET 

J=l  SOME  IARGS  ARE  NEGATIVE,     J=2  MATRIX  TO  BIG  FOR  WORK  SHEET 
COMMON  /BLOCKD /  IARGS(IOO) ,KIND(100) ,ARGTAB (100) , NRMAX , NROW, NCOL , 
1ARGS,VWXYZ(8) ,NERROR 
JA=J 
JB=4*J 
J=0 

DO  10  1=1 , JB 

IF  (IARGS(I) .GT.O)  GO  TO  10 
J=l 

RETURN 

CONTINUE 

DO  20  1=1, JB, 4 

IF  (IARGS(I)+IARGS(I+2)-l.GT.NR0W)  GO  TO  30 
IF  (IARGS(I+l)+IARGS(I+3)-l.GT.NC0L)  GO  TO  30 
IARGS ( I ) =1 ARGS ( I ) + (IARGS ( I +1 ) -1 ) *NROW 
RETURN 
J=2 

RETURN 
END 


MCK  100 
MCK  110 
MCK  120 
MCK  130 


MCK 
MCK 
MCK 
NMCK 


140 
150 
160 
180 


MCK  190 
MCK  220 
MCK  230 
MCK  240 
MCK  250 
MCK  260 
MCK  270 
MCK  280 
MCK  290 
MCK  300 
MCK  310 
MCK  320 
MCK  330 
MCK  340 
MCK  350 
MCK  360 
MCK  370 
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SUBROUTINE  MXTX 
VERSION  5.00 


MXTX 


5/15/70 


SUBROUTINE  MXTX  R.V.  5/7/68 


SUBROUTINE  TO  MULTIPLY  MATRIX  A  BY  ITS  TRANSPOSE 
OR  TRANSPOSE  OF  MATRIX  A  BY  MATRIX  A 
L2=l    MULTIPLY  MATRIX  BY  ITS  TRANSPOSE 
GENERAL  FORM  OF  COMMAND 

M(XXT)     A(.)  N,K,     STORE  IN    C(()        N,K  DEFINE  X 
L2=2    MULTIPLY  TRANSPOSE  OF  MATRIX  BY  ITSELF 
GENERAL  FORM  OF  COMMAD 

M(XTX)     A(,)  N,K    STORE  IN    C(,)        N,K    DEFINE  X 

* 

COMMON  /SCRAT/  NS  ,NS2 ,A (13500) 
COMMON  /BLOCRC/  NRC  , RC  ( 12600 ) 

COMMON  /BLOCKD /  I ARGS ( 100 ) ,KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW.NCOL 

1ARGS,VWXYZ(8) ,NERROR 

DIMENSION  ARGS(IOO) 

EQUIVALENCE  (ARGS ( 1 ), RC  ( 12501 ) ) 

COMMON  /BLOCKE /  NAME (4) ,L1 ,L2 , ISRFLG 

DOUBLE  PRECISION  AP(3000) 

EQUIVALENCE  (A,AP) 
* 

CHECK  FOR  CORRECT  NUMBER  OF  AGRUMENTS 

* 

* 

DECIDE  WHETHER  COMMAND  IS  M(XAX')  OR  M(X'AX) 

L2=3  MEANS  M(XAX')  L2=2  NARGS.GT.  6  MEANS  M(X'AX) 

* 

IF  (L2-2)  30,10,20 

IF  (NARGS.LE.6)  GO  TO  30 

L2=4-L2 

CALL  TRANSF 

RETURN 

IF  (NARGS .NE .6)  CALL  ERROR  (10) 
* 

CHECK  TO  SEE  IF  ALL  ARGUMENTS  ARE  INTEGERS 

* 

J=NARGS 

CALL  CKIND  (J) 

IF  (J.NE.O)  CALL  ERROR  (3) 

* 

CHECK  TO  SEE  IF  DIMENSIONS  ARE  OUT  OF  RANGE 

COMPUTE  ADDRESSES 
* 

GO  TO  (50,60)  ,  L2 
IARGS(8)=IARGS(3) 
IARGS(7)=IARGS(3) 
GO  TO  70 

IARGS(8)=IARGS(4) 
IARGS(7)=IARGS(4) 
J=2 

CALL  MTXCHK  (J) 
IF  (J-l)  100,80,90 
CALL  ERROR  (3) 
RETURN 

CALL  ERROR  (17) 
RETURN 


MXT 
MXT 
MXT 
MXT 
MXT 
MXT 
MXT 
MXT 
MXT 


10 
20 
30 
40 
50 
60 
70 
80 
90 


MXT  110 

MXT  120 

MXT  130 

MXT  150 

MXT  160 

MXT  170 

, NMXT  180 

MXT  190 

MXT  200 

MXT  210 

MXT  220 

MXT  230 

MXT  240 

MXT  250 

MXT  260 

MXT  270 

MXT  280 

MXT  290 

MXT  300 

MXT  310 

MXT  320 

MXT  330 

MXT  340 

MXT  350 

MXT  360 

MXT  370 

MXT  380 

MXT  390 

MXT  400 

MXT  410 

MXT  420 

MXT  430 

MXT  440 

MXT  450 

MXT  460 

MXT  470 

MXT  520 

MXT  530 

MXT  540 

MXT  550 

MXT  560 

MXT  570 

MXT  580 

MXT  590 

MXT  600 

MXT  610 

MXT  620 

MXT  630 

MXT  640 

MXT  650 
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C         CHECK  FOR  PREVIOUS  ERRORS  MXT  660 

C         *  MXT  670 

100      IF  (NERROR.NE.O)  RETURN  MXT  680 

IG=IARGS(1)  MXT  690 

CALL  MXTXP  (RC(IG) ,NROW, IARGS (3 ) ,IARGS(4) ,A ,L2 ,NS2 , AP)  MXT  700 

GO  TO  (110,120)  ,  L2  MXT  710 

110      NR0WP=IARGS(3)  MXT  720 

GO  TO  130  MXT  730 

120      NR0WP=IARGS(4)  MXT  740 

130      NCOLP=NROWP  MXT  750 

IG=IARGS(5)  MXT  760 

CALL  STORMT  (RC(IG) ,NROW,NROWP ,NCOLP , A)  MXT  770 

C         *  MXT  780 

C         MOVE  FROM  SCRATCH  AREA  TO  STORAGE                                                        MXT  790 

C         *  MXT  800 

RETURN  MXT  810 

END  MXT  820 
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CIIDDAIITTKIC     HVT  VD      /V     Al     HID     1/      A     1   O     Al  A  C  ?  *7  P*  VA\ 

SUBROUTINt  MXTXP   ( X , N , NP , K , A , L2 , NAS 1 ZE , XP ) 

AAV  D 

MXP 

10 

c 

l/COC  T  All         C     A  A                   ft  1 V  TVD  c/ir*TA 

VERSION     5.00          MXTXP  5/15/70 

ftIV  D 

MXP 

O  A 

20 

c 

fimnAiiTTiir    aiv  T  v  A             a    ti  t  ntirn                        ,  n  </••-, 

SUBROUTINE  MXTXP        R  VARNER  2/12/68 

o  i  w  A 

MXP 

30 

c 

a,  1  w  p. 

MXP 

40 

c 

v/    t  <~    in  ti  t  \/    t  a    a  r-    i  if  r  n 

X  IS  MATLIX  TO  BE  USED 

AIV  A 

MXP 

50 

c 

ki    t  r*    at  ur  nr  t  Aiirn    p*  t  t  r*    ap  a 

N  IS  DIMENSIONED  SIZE  OF  A 

MXP 

60 

c 

*  i  r\     t  c    bill  un  r-  r>    at    n  a  uip"     y  m  a 

NP  IS  NUMBER  OF  ROWS  IN  A 

i|y  r\ 

MXP 

70 

c 

1/          t  P"      (LI  1  1  tin  r*  n      AT     A  A 1    II  Alii  C      T  Al  A 

K     IS  NUMBER  OF  COLUMNS  IN  A 

MXP 

80 

c 

1  O     1       All  1 1  Ttni  U    V    T  T  uc  c    v    td  incnAccn 

L2=l     MULTIPLY  X  TIMES  X  TRANSPOSED 

AIV  D 

MXP 

A  A 

90 

c 

■  "i    *■»       kai  ii  x  t  r>  i  \/    \/    m  iiif  nAfrn    tt  Air*  c  v 

L2=2     MULTIPLY  X  TRANSPOSED  TIMES  X 

uv  a 

MXP 

100 

c 

Al  A  P"  T  T  P*       T  C      r  T  T  T      AP"       A       ATI/TATA      AW  *\ 

NASIZE  IS  SIZE  OF  A  DIVIDED  BY  2 

MXP 

110 

c 

A       TP*      P1  A  A  A  T  A  1  1       A  A  P"  A       till  irAP      III  Tfi  7  U       TP*      T  A      AP"      P*  T  A  A  P"  A 

A  IS  SCRATCH  AREA  WHERE  MATRIX  IS  TO  BE  STORED 

MXP 

120 

a 

c 

* 

||w  r\ 

MXP 

130 

AAiioi  r     DDCATCTAM    VD     CI  III 

UUUbLt  PKtLlblUN  XP,bUM 

AIV  D 

MXP 

140 

A  T  lirilC  T  All     V  /  Al      i   \           &    /  i    \          w  r\  /  t  » 

DIMENSION  X(N,1),  A(l),  XP(1) 

MXP 

150 

T  A  1 

I  C=l 

MXP 

160 

A  A      T  A       /  ^  A       a  s\  \            i  a 

GO  TO  (10 ,40)  ,  L2 

t  aw  A 

MXP 

170 

c 

AAA1AIITP*      V      T  T  lir  f      \J      T  A  A  IIT  AATm 

COMPUTE  X  TIMES  X  TRANSPOSED 

ft  IV/  A 

MXP 

180 

C 

ft  iw  pj 

MXP 

190 

10 

AA      OA      1/1/       1  AIA 

DO  30  KK=1,NP 

AIV  D 

MXP 

O  A  A 

200 

AA      OA       T       1       Al  A 

DO  30  I=1,NP 

■  |w  p» 

MXP 

210 

TP"  AIACTTP* 

IS=NASIZE 

AIV  A 

MXP 

220 

UU   20  J=l ,K 

AIV  D 

MXP 

1  1  A 

230 

v/ft  /  T  P  \      V  /  T       I  \  *  w  /  i/  i/  iv 

XP(IS)=X(I , J ) *X (KK , J ) 

AIV  A 

MXP 

240 

T  C     T  C  1 

AIV  D 

MXP 

OCA 

250 

OJtl  1      CrtDTCII     /I/     CI  III \ 

CALL  SOKISM  (K,SUM) 

AIV  D 

MXP 

A  /  A 

260 

A    /  T  A  \       C  1  1  Al 

A ( IC )=SUM 

AIV  D 

MXP 

270 

30 

T  A       T  A  1 

IC=IC+1 

AIV  D 

MXP 

A  A 

280 

RETURN 

AAV  A 

MXP 

290 

C 

♦ 

AIV  D 

MXP 

O  A  A 

300 

c 

A  A  AAA  1  1  T  P*          w      TAAAIP"AAP"P"A      TT  A  IP"  P*  V/ 

COMPUTE    X  TRANSPOSED  TIMES  X 

AAV  A 

MXP 

OTA 

310 

pv 

c 

♦ 

MXP 

O  O  A 

320 

40 

A  A      /  r\      1         1  W 

DO  60  L=1,K 

MXP 

O  O  A 

330 

A  A      /  r\        ■       i  ■/ 

DO  60  J=1,K 

IIV  O 

MXP 

O  il  A 

340 

TC  1I1CT7C 

Ib=NASIZE 

MXr 

350 

riA     cA     T      1      11 D 

DU  50   1=1 ,  NP 

MY  D 

Mat 

1  L  f\ 

360 

V  A  /  T  P*  \       v/  /  T         ■  ■        V   i  T       1  \ 

XP ( IS )=X ( I ,J)*X(I ,L) 

iiv  n 

MXP 

OTA 

370 

50 

TP"       TP"  T 

I S=I S-l 

IIV  D 

MXr 

380 

AAI   1       CADTCH     /AID     C  1  1  il  \ 

CALL  SORTSM  (NP,SUM) 

MV  D 

MXr 

390 

A    /  T  A  \       P*  1  1  AA 

A ( IC )=SUM 

IIV  D 

MXP 

AAA 

400 

60 

T  A       T  A  1 

I C=I C+l 

MXP 

il  1  A 

410 

r*t  i-  tt  ■  i  r\  ft  i 

RETURN 

AIV  A 

MXP 

420 

END 

MXP 

430 
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SUBROUTINE  NNAME 

(NAME) 

NNA 

10 

c 

VERSION  5.00 

NNAME 

5/15/70 

NNA 

20 

COMMON  /BLOCKA/  MODE , M, KARD (83 ) ,KARG , ARG , ARG2 , NEWCD (80 ) , KRDEND 

NNA 

30 

DIMENSION  NAME (2 ) 

,  MISC(6) 

NNA 

40 

c 

NNA 

50 

c 

THIS  SUBROUTINE  ASSEMBLES  A 

NAME  UP  TO  THE  FIRST 

NON-LETTER  OR  UP 

NNA 

60 

c 

SIX  LETTER,  WHICHEVER  IS  FIRST.  THE  INDEX,  M, 

IS 

INITIALLY  POINTINNNA 

70 

c 

THE  FIRST  LETTER, 

IT  IS  LEFT 

POINTING  AT  THE 

FIRST  NON 

-LETTER . 

NNA 

80 

c 

NNA 

90 

c 

SPACE  OUT 

SO  THAT  TABLE  LIES    ALL  ON 

ONE 

PAGE 

NNA 

100 

c 

NNA 

110 

c 

NNA 

120 

c 

CONVERSION  TABLE  FOR  ALPHABETIC  TO  NUMERIC 

AS 

USED 

BY  OMNITAB. 

NNA 

130 

c 

NNA 

140 

c 

A 

729 

27  1 

NNA 

150 

c 

B 

1458 

54  2 

NNA 

160 

c 

C 

2187 

81  3 

NNA 

170 

c 

D 

2916 

108  4 

NNA 

180 

c 

E 

3645 

135  5 

NNA 

190 

c 

F 

4374 

162  6 

NNA 

200 

c 

G 

5103 

189  7 

NNA 

210 

c 

H 

5832 

216  8 

NNA 

220 

c 

I 

6561 

243  9 

NNA 

230 

c 

J 

7290 

270  10 

NNA 

240 

c 

K 

8019 

297  11 

NNA 

250 

c 

L 

8748 

324  12 

NNA 

260 

c 

M 

9477 

351  13 

NNA 

270 

c 

N 

10206 

378  14 

NNA 

280 

c 

0 

10935 

405  15 

NNA 

290 

c 

P 

11664 

432  16 

NNA 

300 

c 

Q 

12393 

459  17 

NNA 

310 

c 

R 

13122 

486  18 

NNA 

320 

c 

S 

13851 

513  19 

NNA 

330 

c 

T 

14580 

540  20 

NNA 

340 

c 

U 

15309 

567  21 

NNA 

350 

c 

V 

16038 

594  22 

NNA 

360 

c 

w 

16767 

621  23 

NNA 

370 

c 

X 

17496 

648  24 

NNA 

380 

c 

Y 

18225 

675  25 

NNA 

390 

c 

Z 

18954 

702  26 

NNA 

400 

c 

NNA 

410 

c 

NNA 

420 

c 

THE  FIRST  THREE  CHARACTERS  GO  INTO  THE  FIRST 

WORD 

OF  NAME 

NNA 

430 

c 

THE  SECOND  THREE  CHARACTERS 

GO  INTO  THE  SECOND  WORD  OF 

NAME 

NNA 

440 

c 

NNA 

450 

c 

NNA  460 

DO  10  1=1,6 

NNA 

470 

10 

MISC (I )=0 
DO  20  1=1,6 
L=KARD (M)-9 

NNA 
NNA 
NNA 

480 
490 
500 

IF  (L.LT.l.OR.L.GE 

.27)  GO  TO 

40 

NNA 

510 

MISC(I)=L 

NNA 

520 

20 

M=M+1 

NNA 

530 

30 

IF  (KARD (M) .LT.10. 

M=M+1 

GO  TO  30 

OR .KARD (M) 

.GE.36)  GO  TO  40 

NNA 
NNA 
NNA 

540 
550 
560 

40 

NAME(l)=MISC(3)+27 
NAME(2)=MISC(6)+27 

*(MISC(2)+27*MISC(1)) 
*(MISC(5)+27*MISC(4)) 

NNA 
NNA 

570 
580 

RETURN 

NNA 

590 

END 
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NNA 

600 

FUNCTION  NONBLA  (I)  NON  10 

C         VERSION    5.00         NONBLA         5/15/70  NON  20 

C  NON  30 

C         SCAN  KARO  STARTING  AT  KARO(I)  UNTIL  A  NON-BLANK  CHARACTER  IS           NON  40 

C         FOUND.     POINT  M  AT  IT  AND  ALSO  RETURN  IT  AS  FUNCTION  VALUE.             NON  50 

COMMON  /BLOCKA/  MODE ,M,KARD (83 ) ,KARG , ARG , ARG2 ,NEWCD (80 ) ,KRDEND        NON  60 

M=I  NON  70 

10        IF  (KARD(M) .NE.44)  GO  TO  20  NON  80 

M=M+1  NON  90 

GO  TO  10  NON  100 

20        NONBLA=KARD (M)  NON  110 

RETURN  NON  120 

END  NON  130 


SUBROUTINE  NOTEPR(J)  NOT  10 

C         VERSION    5.00         NOTEPR        5/15/70  NOT  20 

C         WRITTEN    BY  STP    4/21/70  NOT  30 

C  NOT  40 

C  IF  J=0  BLANK  OUT  NOTE  VARIABLE  NOT  50 
C          IF    J=l  STORE  IN  NOTE(l)  THRU  N0TE(60)  FROM  NEWCD  (M-2)  60  CHAR      NOT  60 

C          IF    J=2  STORE  IN  N0TE(61)  THRU  N0TE(120)  FROM  NEWCD  (M-2)  60  CHAR  NOT  70 

C          IF    J=3  PRINT  OUT  NOTE(l)  THRU  N0TE(120)                                             NOT  80 

C  NOT  90 

COMMON /BLOCKA /MODE , M,KARD (83 ) , KARG , ARG ,ARG2 , NEWCD (80 ) ,KRDEND  NOT  100 

COMMON/HEADER/NOCARD (80) ,ITLE(60,6) , LNCNT , IPRINT (NPAGE , I  PUNCH  NOT  110 

C0MM0N/N0TE/N0TE(120)  NOT  120 

DATA  IBLANK/1H  /  NOT  130 

IF  (J.NE.O)  GO  TO  20  NOT  140 

DO  10  1=1,120  NOT  150 

10        NOTE ( I )=IBLANK  NOT  160 

RETURN  NOT  170 

20        IF(J.NE.3)  GO  TO  40  NOT  180 

IF(NPAGE.EQ.O)  CALL  PAGE(O)  NOT  190 

WRITE  (IPRINT, 30)   (NOTE ( I ) , 1=2 , 120 )  NOT  200 

RETURN  NOT  210 

30        F0RMAT(1X,119A1)  NOT  220 

40        MA=M+60  NOT  230 

M=M+1  NOT  240 

IF(MA.GT.82)  MA=82  NOT  250 

MB=(J-1)*60+1  NOT  260 

MC=MB+59  NOT  270 

IF (J .NE.l.AND.J .NE.2)  RETURN  NOT  280 

DO  100      I=MB,MC  NOT  290 

100      NOTE ( I )=IBLANK  NOT  300 

I=MB  NOT  310 

DO  110    IC=M,MA  NOT  320 

N0TE(I)=NEWCD(IC-2)  NOT  330 

110      1=1+1  NOT  340 

RETURN  NOT  350 

END  NOT  360 


186 


SUBROUTINE  OANOVA  (YSUM, SU , ND9 , FM, M,N , ND7 , SSQ , IHC , NSU , B ) 

0AN 

10 

c 

VERSION    5.00         OANOVA  5/15/70 

0AN 

20 

c 

COMPUTE  AND  PRINT  ANALYSIS  OF  VARIANCE 

0AN 

30 

c 

WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS .  10/09/69. 

0AN 

40 

c 

***** 

0AN 

50 

COMMON /BLOCKD/ I ARGS ( 100) , KIND (100) ,ARGTAB (100) , NRMAX , NROW , NCOL , 

0AN 

60 

1NARGS,VWXYZ(8) ,NERROR 

0AN 

70 

COMMON/BLOCKE/NAME (4 ) ,L1 ,L2 , ISRFLG 

0AN 

90 

COMMON/HEADER /NOCARD  (80)  ,ITLF.(60,6)  ,  LNCNT  ,  I  PR  I  NT  ,NP  AGE  ,  I  PUNCH 

0AN 

100 

COMMON /SCR AT / NS ,NS2 , A (13500) 

0AN 

110 

n  t  tir  ii  r  t  aii     ft   /       >       t  i  i  a  *  *  . 

DIMENSION  B(l) , IHC ( 1 ) 

0AN 

160 

r\  A  i  1  n  i    r—       ft  A.  r~  />  T  C  T  A  •.  1       w  r  1  1  11 

DOUBLE  PRECISION  YSUM 

0AN 

170 

c 

*  *  *  *  * 

*r  •T*  t*  T 

0AN 

180 

1850 

r\  r~  c  j  ir            \<  r  m  n  i  n  i 

RESMS  =  YSUM/SU 

OAN 

190 

NSUA  =  NSU 

0AN 

200 

IT  =  1 

OAN 

210 

IF   (L2.EQ.3)  IT=3 

OAN 

220 

III  A  T  TP       /  T  nn  T  llT      i  a  /  a  i        1  IIA  f  T  T  t        tiiA  /  it      •%  \ 

WRITE  ( IPRINT  ,  1860 )  IHC  (IT) , IHC (IT+1) 

OAN 

230 

1860 

rAniii  t     /  /  /  /  /  r  ft  u     ft  ft  1 1  i  ii  it  i  \i  c  7  c     a  r~    vi  a  n  t  i  n/>r  /  a  4  v/    tftii  hrnrnnrnT 

FORMAT   ( / / / /50X , 20HANALYSIS  OF  VARIANCE/24X , 73H-DEPENDENT 

ON  0RDER0AN 

240 

1  VARIABLES  ARE  ENTERED,  UNLESS  VECTORS  ARE  ORTHOGONAL-// 

OAN 

250 

A  1  \/           A  ->       «  w                                             a  i  |  |      f*  A      p\  r  f\          r\  1  I  r      T  A      A  A  IT"  i-           aim              a  i  i  ii  iia 

21X,2A3,4X,                21H  SS=RED .  DUE  TO  C0EF.,21H      CUM.  MS 

REDUCTI00AN 

260 

ifci        /II        r\     r~        a  ^  1 1           a  i  in       nrr  t  mi  a  i      nr            /■■        r\     r*        t  n  n  n        r  /  A  apt 

3N  ,6H    D.F.,21H      CUM.  RESIDUAL  MS     ,6H     D.F.,11H  F(C0EF= 

ft  \  >ii 

=0)  ,6H 

ft  A  A  li 

POAN 

270 

4(F), 11H  F (C0EFS=0 ) , 6H  P(F)/) 

OAN 

280 

IND9  =  ND9+M 

a  i  II 

OAN 

290 

A  C  1  1 1J           A  A 

AbUM  =0.0 

All! 

OAN 

300 

tin            CM     C 11 

VR  =  SU-FM 

OAN 

340 

RESSS  =  VR*SSQ 

OAN 

350 

T  lim                ||  A  *T       |  J 

IND7  =  ND7+M 

OAN 

400 

A(IND7)  =  RESSS 

OAN 

410 

TP"  /  n    T~  ft     t  \      A  A     T  A  ift// 

IF(M.EQ.l)  GO  TO  1866 

A  |  || 

OAN 

415 

A  A      i  A  /  C*      T  1       A  ftfl 

DO  1865  11=2, M 

OAN 

420 

IND7  =  IND7-1 

OAN 

430 

a  /  t  iirt  \           i  /  t  im^     t  \           a  /  tiiaa  \ 

A(IND7)  =  A(IND7+1)  +  A(IND9) 

OAN 

440 

1865 

i  Hf\  a              t  iir\  a  n 

IND9  =  IND9-1 

OAN 

450 

1866 

\i  i  r  ft               r  |i      i  a 

V1F2  =  FM+1 . 0 

OAN 

460 

B(l)  =  A(IND9-1) 

OAN 

470 

B(2)  =  A(IND9-2) 

OAN 

480 

1      i    T  II  ft  A         n     »                        \  /  A  1  1  1  1 

A(IND9-1)  =  YSUM 

OAN 

482 

1      t    V  II  ft  ^fc         A    *                        P*i  fr™  AAA 

A(IND9-2)  =  RESSS 

ClAW 

484 

A    II       1              A          A  ft  1  l"P             s     1       '     T    Q  1  A  A           M,     V             1  ft         ft           ft           II  lif  1            |  1  |7%,   f  .ft   «             *     ft            A       ,     *1       »              A        ,     ^       .             A           A  % 

CALL  RF0RMT  (A ( IND9-2 ) , M+2 , 8 , NW1 , NDECl , 18 , A (1 ) , A ( 1 ) , 0 , 0 ) 

OAN 

490 

A(IND9-1)  =  B(l) 

OAN 

492 

A(IND9-2)  =  B(2) 

OAN 

494 

A    M    |       £               A   |—  A  ft  |                        il       /     Til  ft  A     l             II         ft           II  III  A           1 1  ft  A  ft  ft            ■>     ft            |       /     n      i              1       ,     «      .              —            A  \ 

CALL  RF0RMT  (A ( IND9) ,M, 8 ,NW2 ,NDEC2 , 18 , A (1 ) ,A(1) ,0,0) 

OAN 

496 

SSU=SU 

OAN 

498 

DO  1867  1=1, M 

OAN 

500 

A   A  |  |           A  A  |   1           —  *\ 

SSU=SSU-1 .0 

OAN 

505 

B(I)=A(IND7) /SSU 

OAN 

510 

1867 

IND7=IND7+1 

OAN 

515 

IND7=IND7-M 

OAN 

520 

CALL  RF0RMT (B (1 ) , M, 8 ,NW3 ,NDEC3 , 18 , A (1) ,A(1) ,0,0) 

OAN 

525 

SSU  =  SU 

OAN 

530 

DO  1950  1=1, M 

OAN 

540 

NSUA  =  NSUA-1 

OAN 

550 

ASUM  =  ASUM+A(IND9) 

OAN 

560 

SSU  =  SSU-1.0 

OAN 

570 

CR  =  ASUM/FL0AT(I) 

OAN 

580 

IF  (ABS(SSU) .GT.0.0)  GO  TO  1880 

OAN 

590 

RESMS  =0.0 

OAN 

600 

1870 

Fl  =  0.0 

OAN 

610 

187 


F2  =  0.0 

0AN 

620 

PF1  =1.0 

0AN 

630 

PF2  =1.0 

0AN 

640 

A      T  A      T  A  A  A 

GO  TO  1890 

A  1  II 

OAN 

/FA 

650 

1880 

RESMS  =  A ( IND7 )  /SSU 

0AN 

660 

V1F2  =  V1F2-1 . 0 

OAN 

670 

IF  (ABS (RESMS) .LE .0 .0)  GO  TO  1870 

OAN 

680 

A 

C 

Mrijrn  nAAl 

NEVtK  POOL 

A  A  AI 

UAN 

Z  A  A 

690 

p-                      1    /  T  llf\  A  \  /AAA 

Fl  =  A ( IND9 ) /SSQ 

A  A  AI 

OAN 

700 

CALL  PR0B  (1 .  , VR , Fl ,PF1 ) 

A  A  AI 

OAN 

710 

A 

C 

TEST  HIGHER  SUB-HYPOTHESES 

A  111 

OAN 

T  A/V 

720 

p*  a            /  f  i  /  t  kii\7  \     t  /  t  kin  n  \     nrp  r  f  \   iwi         \   /  <*  a  a 

F2  =  ( (A ( IND7 ) +A ( IND9 ) -RESSS ) /V1F2 ) /SSQ 

A  A  AI 

OAN 

730 

Aiii      n  n  n  n     ft/i  ro    w  a,    p"  a     n  r*  a  \ 

CALL  PROB  (V1F2  ,VR  ,F2  ,PF2) 

A  A  AI 

OAN 

740 

1890 

TT                T  A  PI  A    /  T       1  \ 

II  =  IABS(I-l) 

A  1  II 

OAN 

750 

a  i  i  i      n  r  A  n  iit     s  a  /  i  v     i     a    n  un     n  i\  r  A  i     a     «  /  t  ti  f\  a  \     n  /     i\     a  i     n  tun     n  \ 

CALL  RF0RMT  (A (1 ) , 1 , 8 , NW1 ,NDEC1 , 0 , A ( IND9 ) , B (  1),21-NW1,1) 

A  A  AI 

OAN 

760 

a  i  i  i      n  i~  a  n  bat     /  a  /  t  \     i     a    a  i  til       iinrA  a    a          a  r*             n  /  a  a  \        -»     ai  hi  a     ^  > 

CALL  RFORMT  ( A ( 1 ) , 1 , 8 , NW2 , NDEC2 , 0 ,     CR      , B (22 ) , 21-NW2 , 1 ) 

A  A  AI 

OAN 

770 

a  a  i   i      n  r*  A  ri  a  at      /  a  /  i  \      i      r»     ai  mi  *i     n  r\  r  a  o     /%        n  r*  <~  a  *r        a  /  /i  *»  \      ai     ii  mi  a     -s  \ 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW3 , NDEC3 , 0 ,  RESMS  , B (43 ) , 21-NW3 , 1 ) 

A  A  AI 

OAN 

780 

t  (—     /  i  a    r*  A    i  \     a  f\    t  A     i  n  i  n 

IF   (L2.EQ.1)  GO  TO  1920 

A  A  AI 

OAN 

T  A  A 

790 

WRITE  (IPRINT , 1900)  I ARGS ( 1+3 ) , (B ( 1 1 ) , 1 1=1 , 42 ) , I , (B ( 1 2 ) , 1 2- 

AO       e  *t  \  AAAI 

=43 ,63) ,0AN 

800 

i  ai  f*  1 1  a     r~  i     Pi  i~  *i     r"A    r\  r"  a 

1NSUA ,  Fl ,PF1 ,F2 ,PF2 

A  A  AI 

OAN 

810 

1900 

FORMAT  (1X,I4,6X,42A1<I6,21A1,I6,2(0PF11.3,F6.3)) 

OAN 

820 

A      T  A      1  A  /•  A 

GO  TO  1940 

A  A  AI 

OAN 

830 

1920 

WRITE  ( IPRINT  ,  1900 )     1 1 , (B ( 1 1 ) , 1 1=1 ,42 ) , I , (B ( 12 ) , 1 2=43 , 63 ) 

,  OAN 

840 

i  ai  f  1 1  a     t~  i     a  P"  i      r~  a  r*p"A 

1NSUA,F1,PF1,F2,PF2 

A  A  II 

OAN 

850 

1940 

IND7  =  IND7+1 

A  A  AI 

OAN 

860 

1950 

T  AI  A  A               T  kin  A  1 

IND9  =  IND9+1 

A  A  AI 

OAN 

870 

1951 

r  An  in  t     /t     i  \j     i  Aimrr  t  nn  i  i               i  a  ^     <\  n  \j     t  /  \ 

FORMAT  (/ ,  IX , 10HRESIDUAL     ,21A1 ,21X , 16) 

A  A  AI 

OAN 

880 

1952 

r~  A  A  I M  A  TT         i        V/                   ^    /Nil  T  A  t*  AI                                      j"s  n    A    %         /\  «   \/        T    S  \ 

FORMAT  (IX,     10HT0TAL          ,21A1 ,21X, 16) 

OAN 

890 

r-  ^           r»  r*  f  a  a 

Fl  =  RESSS 

A  A  AI 

OAN 

900 

Aii  ■      nrrtn  a  it     /  a  /  -a  \     i     a    ai  iqi  i     a  i  n  f"  a  i     a     r*i                          D  /  i  \     ai     III  ill  i  i\ 

CALL  RFORMT   (A ( 1 ) , 1 , 8 ,NW1 ,NDEC1 , 0 , Fl                B ( 1 ) , 21-NW1 , 1 ) 

A  A  fcl 

OAN 

A  1  A 

910 

Ifll  A  T  T  r~         /  THAT  IIT       i  r\  r  t    \          /  A    /   T   \         T        ^        <1  1    \  AlAIIA 

WRITE  ( IPRINT  ,  1951 )   (B ( I ) , 1=1 , 21 ) , NSUA 

A  A  AI 

OAN 

920 

ir~  a          v/  n  111 

F2  =  YSUM 

A  A  AI 

OAN 

A  O  A 

930 

A  A  |    1       A  r*  A  n  KIT       /  A   y  1   v       1       A      LI1U1      fclftTP  1       A      E"  A      D/i\      AI      AI  IIM  1\ 

CALL  RFORMT   (A ( 1 ) , 1 , 8 , NW1 ,NDEC1 , 0 , F2 ,B ( 1 ) , 21-NW1 , 1 ) 

UAN 

A  A  A 

940 

III  A  T  T  A1         /  T  A  A  T  IIT       1        r  <*>  \          /  A    /   T    \         T        TI        A1\        Riri  I 

WRITE  ( IPRINT , 1952 )   (B ( I ) , 1=1 , 21 ) , NSU 

A  A  AI 

OAN 

950 

RETURN 

A  A  II 

OAN 

960 

END 

OAN 

970 

188 


SUBROUTINE  OCOEFF  (Ml , N , ND18 , ND17 , IND19S , IND18S , IHC , B , IND7S , NSU , SSOCO 

10 

1 ,SSOLD,YSUM) 

0C0 

20 

c 

VERSION    5.00         OCOEFF  5/15/70 

OCO 

30 

c 

WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS  .  10/14/69. 

0C0 

40 

c 

s|e  $  *  $  * 

OCO 

50 

C0MM0N/BL0CKD/IARGS(100) .KIND(IOO) ,ARGTAB(100) ,NRMAX ,NROW,NCOL , 

OCO 

60 

1NARGS,VWXYZ(8) ,NERROR 

OCO 

70 

COMMON /BLOCKE /NAME (4) , LI , L2 , I SRFLG 

AAA 

OCO 

90 

COMMON /HEADER /NOCARD (80 ) , ITLE (60 , 6 ) , LNCNT , I  PR  INT , NPAGE  ,  IPUNCH 

OCO 

100 

COMMON /SCRAT/NS,NS2 , A (13500) 

OCO 

110 

DIMENSION  B(l)  ,  IHC  (1 ) 

OCO 

160 

DOUBLE  PRECISION  YSUM 

OCO 

165 

c 

$  $  $  $  $ 

OCO 

170 

IT  =  1 

OCO 

180 

IF  (L2.EQ.3)  IT=3 

OCO 

190 

M  =  Ml+1 

OCO 

200 

WRITE  (IPRINT , 1960)   IHC ( IT ) , IHC ( IT+1 ) , IHC ( IT ) , IHC ( IT+1 ) 

OCO 

210 

1960 

FORMAT  (////20X,32HESTIMATES  FROM  LEAST  SQUARES  FIT , 38X , 18HFIT  OMIOCO 

220 

1TTING  LAST   , 2A3 / /IX , 2 A3 , 5X , 11HC0EFFICIENT , 8X  ,  14HS  .  D  .  OF  COEFF . ,4X ,0C0 

230 

25HRATT0          1?H*APP      HTRTT^   QY   1  1  HPflFFF  T  P  T  FNT   7Y   ldH^   n  DF 

PflFFF 
L»ucr  r 

npn 

240 

icy    CUD  AT  T  fi  /  \ 

nrn 

250 

T  kin  1  Q  M.KlDIQil 
INDUS  =  IM+NUlo+1 

nnn 

260 

Turn  7      urn  7  ,  i 

J.IMU1/    =  NU  1  /  +  i 

UL-U 

270 

UL-U 

280 

t  un  io       iMm  oc  ,  i 

UL-U 

290 

t  wr»7       t  wri7C  .  i 

1 IMU  /    =    1  NV  1  o  +  i 

npn 
ULU 

300 

t  ALL   KrUKMI     ( A  ( 1IMUJ.7  )  ,  Ml+1  ,  0  ,  NW1  ,  NUtvl  ,  10  ,  A  ( 1 )  ,  A  ( 1 )  ,  U  ,  0  ) 

OCO 

310 

n  A  1  1      DTAD  UT      /  A  /  T  M  fl  1      \     111.1      O     Kl  W 1     linrp*!     to     A/1\      A/1\     n  n\ 

LALL  KrUKMI    (A(1NU1   ) , Ml  +  1 , 8 , NWZ , NDLL2 , 18 , A ( 1 ) , A ( 1 ) , 0  , 0 ) 

OCO 

320 

TC       /111      fA      A  \      A  f\     T  f\      A  A  A  C 

1  r    (Ml . tQ . 0  )   bU    1  U  2005 

OCO 

330 

oai  I     nrnn  ijt     /A  /  t  m  m  o  \    kit          o    11  ui  o    iinroo    i  o    a  / 1  \     a  /  i  \    a    a  \ 

LALL  KhOKMI    (A ( 1ND18 ) ,  Ml     ,8,NW3,NDtL3,18,A(l) ,  A  ( 1 ) ,0,0) 

OCO 

340 

a  A  I  l     nrnn  ijt     /  a  /  Tlinn  \     Hi          o    m  m  a    mnrP/i     i  o    A/i\     a  /  i  \     a    a  \ 

CALL  RFORMT   (A(IND17),M1     , 8 , NW4 , NDEC4 , 18 , A ( 1 ) , A ( 1 ) , 0 , 0 ) 

OCO 

350 

UU  2000  J=l , Ml 

OCO 

360 

TC      /A  /  TllfM  \  \      T  A  O  A     1  A  O  1      t  a  a  a 

lr    (A(1NU1))  1982,1981,1982 

OCO 

370 

1981 

r 1  =  0.0 

OCO 

380 

GO  TO  1983 

OCO 

390 

1982 

Fl  =  A ( IND19 ) /A ( IND1 ) 

OCO 

400 

1983 

Tr       /  A   /  TMIM  7  \  \       1  A  O  C       1  A  O  A       1  A  O  T 

lr    (A(1NU17))  1985,1984,1985 

OCO 

410 

1984 

F2  =  0.0 

OCO 

420 

GO  TO  1986 

OCO 

430 

1985 

F2  =  A(IND18) /A(IND17) 

OCO 

440 

1986 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW1 , NDECl , 0 , A ( IND19 ) , B ( 1 ) , 20-NW1 , 1 ) 

OCO 

450 

CALL  RFORMT  (A (1 ) ,1,8 ,NW2 ,NDEC2 , 0 , A ( INDl  ) , B (21 ) , 20-NW2 , 1 ) 

OCO 

460 

CALL  RFORMT  (A ( 1 ) , 1 , 8 ,NW3 , NDEC3 , 0 , A ( IND18 ) , B (41 ) , 20-NW3 , 1 ) 

OCO 

470 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW4 , NDEC4 , 0 , A ( IND17 ) , B (61 ) , 20-NW4 , 1 ) 

OCO 

480 

JJ  =  L2/3 

OCO 

490 

JJ  =  IABS(J-1)*(1-JJ)+IARGS(J+3)*JJ 

OCO 

500 

WRITE  (IPRINT, 1990)  J J , (B ( 1 1 ) , 1 1=1 , 40 ) , Fl , A ( IND7 ) , (B ( 12 ) , 12 

=41,80)0C0 

510 

1.F2 

OCO 

520 

1990 

FORMAT  (1X,I4,2X,  40A1 , 0PF7 . 2 , 6X , F5 . 2 , 8X , 40A1 , F7  .  2 ) 

OCO 

530 

IND7  =  IND7+1 

OCO 

540 

IND19  =  IND19+1 

OCO 

550 

IND17  =  IND17+1 

OCO 

560 

INDl  =  IND1+1 

OCO 

570 

2000 

IND18  =  IND18+1 

OCO 

580 

2005 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW1 , NDECl , 0 , A ( IND19 ) , B ( 1 ) , 20-NW1 , 1 ) 

OCO 

590 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW2 ,NDEC2 , 0 , A ( INDl  ) , B (21 ) , 20-NW2 , 1 ) 

OCO 

600 

Fl  =  A(IND19) /A(IND1  ) 

OCO 

610 

NSUA  =  NSU-M 

OCO 

620 

NRM1=  NSU-M1 

OCO 

630 

189 


II    _    1  9  /  % 

npn 

AAfl 

II    —    TAR^fM"l\*M     1  1  \  x  T  ARft^  f  Ml  j.4  ^  *  1  1 

npn 

/L  C  fl 

OjU 

WRTTF    fTPRTNT   lQQfl)     11    /  R  r  T  \    T_i    Afll    Fl  AfTNr)71 

npn 

AAfl 
0  0  U 

p  ai  i   ucnuiuiT  f  Q^ni  n  i  q  nu/9  NfiFP9  i  a  a  m  i  ami  n  n\ 

npn 

A7fl 

D  (K  )  =  JJ 

npn 

A  7  9 

P             AO  MKT    FOR    Ml— n 

u          aujuji   run  ivii=u 

npn 

A  7  A 
0/4 

t f i mi  mf  ni  nn  t n  ?noq, 

npn 

A7  A 
O  /  O 

R/c?\   _  Y^IIM/FI  flAT  (Nl 

npn 

A7fl 
0/0 

d/co\  _  p cnRT f R f r 9 i i 

npn 

ton 
oou 

ifino    PAII     RFDP  MT    (  R  ( 1 9  \    1    fl    M IN  A    N  n  F  P  A    1  fl    Afll    Afll    fl    fl  1 

npn 

Afl9 

PAII     RFflRMT    1  A  f  1  1    1    fl    NU/9    MHFP9    fl    QQni  H    Rm    9(1   NU/9  m 

npn 

0  7  U 

PAII     R  F  H  R  MT    f  A  f  1  1    1    fl    N  U/A    N  fl  F  P  A    fl    D  /  c  9  \    R  /  51  \    in   M  UM    n  \ 

npn 

7flfl 

WRITE  (IPRINT,2010)   (B(I) ,1=1,40) , NSU , M, NSUA , NSU , Ml ,NRM1 

OCO 

7  1  (1 

2010    FORMAT  ( / IX , 30HRESI DUAL  STANDARD  DEVIATION  =  , 3X , 20A1 , 26X , 20A1 /4X , 0C0 

7  9  fl 

128HBASED  ON  DEGREES  OF  FREEDOM  , 9X , 14 , 1H- , 1 2 , 3H  =  ,  13  ,33X,  14 

,1H-,  OCO 

7^n 

212, 3H  =  , 13 / / 120H  *  THE  NUMBER  OF  CORRECTLY  COMPUTED  DIGITS 

IN  EAC0C0 

7  Afl 

3H  COEFFICIENT  USUALLY  DIFFERS  BY  LESS  THAN  1  FROM  THE  NUMBER 

GIVEN0C0 

7  c  n 

4  HERE) 

OCO 

7  Afl 
/  OU 

RETURN 

OCO 

770 

END 

OCO 

780 
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SUBROUTINE  OCOVAR  (M, ND7 , MD1 , IHC , B , IHT )  OCV  10 

C         VERSION     5.00          OCOVAR          5/15/70  OCV  20 

C         PRINT  VARI ANCE-COVARIANCE  MATRIX  OCV  30 

C          WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS .       10/10/69.  OCV  40 

C  *****  OCV  50 
COMMON /BLOCKD/ I ARGS (100) , KIND (100) ,ARGTAB(100) ,NRMAX ,NROW,NCOL ,      OCV  60 

1NARGS , VWXYZ (8 ) ,NERROR  OCV  70 

COMMON /BLOCKE /NAME (4) ,L1,L2,ISRFLG  OCV  80 

COMMON/HEADER/NOCARD (80) ,ITLE(60,6) , LNCNT , I  PR  I  NT ,NPAGE , I  PUNCH  OCV  90 

C0MM0N/SCRAT/NS,NS2 , A (13500 )  OCV  100 

DIMENSION  IHC(l)  ,B(1)  ,IHT(1)  OCV  110 

1750     IND7  =  ND7+1  OCV  120 

1791  FORMAT   ( / / / /31X , 56HVAR I ANCE-COVARIANCE  MATRIX  OF  THE  ESTIMATED  COEOCV  130 
1FFICIENTS)  OCV  140 

1792  FORMAT   ( /IX , 2A3 , IX , 7 (6X , 15 , 4X) )  OCV  150 

1793  FORMAT  (IX , 14  ,3X , 106A1 )  OCV  160 
WRITE  (IPRINT,1791)  OCV  180 
CALL  RFORMT  (A ( IND7 ) , MD1 , 8 , NW1 , NDEC1 , 13 , A ( 1 ) , A ( 1 ) , 0 , 0 )  OCV  190 
IF  (L2.EQ.1)  I6=-l  OCV  200 
IF   (L2.EQ.3)   16=3  OCV  210 

C         I1END  =  NUMBER  OF  BLOCKS  OF  PRINTING  OCV  220 

IlEND=(M+6) /7  OCV  230 

DO  1820  1 1=1 , 1 1END  OCV  240 

I3BEG=7*(I1-1)+1  OCV  250 

I2BEG=I3BEG+I6  OCV  260 

I2END  =  MINO  (M+I6,I2BEG+6)  OCV  270 

IF   (L2-2)  1811,1811,1813  OCV  280 

1811  I7END=I2END+1-I2BEG  OCV  290 
DO  1812  I7=1,I7END  OCV  300 

1812  IHT (17 )=I2BEG-1+I7  OCV  310 
WRITE  (IPRINT,1792)  IHC  (L2) , IHC (L2+1) , (IHT (17 ) , 17=1 , 17END)  OCV  320 
GO  TO  1814  OCV  330 

1813  WRITE  (IPRINT,1792)   IHC (L2 ) , IHC (L2+1 ) , ( I ARGS ( 1 2 ) , 1 2=1 2BEG , 1 2END )     OCV  340 

1814  WRITE  (IPRINT.1793)  OCV  350 
LOCI  =  IND7+( I3BEG* (I3BEG+1) ) /2-1  OCV  360 

C         13  IS  FOR  LOOP  ON  ROWS  OCV  370 

DO  1820  I3=I3BEG,M  OCV  380 

I4END=MIN0  (13 , I3BEG+6)  +  1  -  I3BEG  OCV  390 

C         14  IS  FOR  LOOP  ON  COLUMNS  OCV  400 

DO  1815  14-1,  MEND  OCV  410 
CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW1 , NDEC1 , 0 , A (LOCI ) , B ( 15* 14-14 ) , 15-NW1 , 0 )      OCV  420 

1815  L0C1=L0C1+1  OCV  430 
I5END  =  15*I4END  OCV  440 
IF  (L2.EQ.1)  18  =  13-1  OCV  450 
IF  (L2.EQ.3)  I8=IARGS (13+3 )  OCV  460 
WRITE  (IPRINT,1793)   18 , (B ( 15 ) , 1 5=1 , 1 5END )  OCV  470 

1820    LOCI  =  L0C1-I4END+I3  OCV  480 

RETURN  OCV  490 

END  OCV  500 
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SUBROUTINE  OMCONV  (NWCD , KRD , KRDEND )  OMC  10 

C         VERSION    5.00         OMCONV         5/15/70  OMC  20 

COMMON  /ABCDEF /  L(48)  OMC  30 

C  OMC  40 

C         ARRAY  L  CONTAINS  THE  ALPHABET  FORMATTED    1H  OMC  50 

C  OMC  60 

C         THIS  ROUTINE  CONVERTS  INPUT  CARD  IMAGES  TO  A  STANDARD  CODE  SO  OMC  70 

C         THAT  OMNITAB  CAN  DEAL  WITH  THE  CHARACTERS  AS  INTEGERS.  OMC  80 

C  OMC  90 

C  OMC  100 

C         THIS  ROUTINE  IS  INCLUDED  ONLY  FOR  COMPLETENESS.     IT  SHOULD  BE  OMC  110 

C  REWRITTEN  IN  ASSEMBLY  LANGUAGE  FOR  EACH  COMPUTER.  ALSO,  IT  OMC  120 
C  CANNOT  MEET  ASA  STANDARDS  BECAUSE  ASA  DOES  NOT  REQUIRE  THAT  DATA  OMC  130 
C         READ  WITH  FORMAT    Al    BE  STORED  THE  SAME  AS  HOLLERITH  DATA    SETUP  OMC  140 

C         WITH    1H        ALTHOUGH  THEY  WILL  BE  THE  SAME  ON  MOST  COMPUTERS.  OMC  150 

C  OMC  160 

C         ALSO,  ASA  DOES  NOT  RECOGNIZE  THE  CHARACTER  '  APOSTROPHE  OMC  170 

C  OMC  210 

DIMENSION  NWCD(l),  KRD  ( 1 )  OMC  220 

DO  30  1=1, KRDEND  OMC  230 

K=NWCD(I)  OMC  240 

C         SPECIAL  CASE  TO  CHECK  FOR  BLANKS  OMC  250 

IF(K.NE.L(45) )  GO  TO  10  OMC  260 

J=45  OMC  270 

GO  TO  30  OMC  280 

C  OMC  290 
C         THE  UPPER  BOUND  OR  LIMIT  ON  J  MUST  BE  CHANGED  IF  MORE  CHARACTERS    OMC  300 

C         ARE  ADDED  TO  THE  VECTOR  L  IN  LABEL  COMMON  ABCDEF  OMC  310 

C  OMC  320 

10  DO  20  J=l,48  OMC  330 

IF(K.EQ.L(J) )  GO  TO  30  OMC  340 

20  CONTINUE  OMC  350 

J=47  OMC  360 

30  KRD(I)=J-1  OMC  370 

RETURN  OMC  380 

END  OMC  410 
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c 
c 


SUBROUTINE  OMNIT 

VERSION  5.00 

*************** 


C 

c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 

10 


c 
c 
c 

20 

c 
c 
c 
c 
c 

30 


OMNIT  5/15/70 
THIS  IS  THE  MAIN  OMNITAB  ROUTINE 
MODE ,M,KARD (83) , KARG ,ARG ,ARG2 ,NEWCD (80) , KRDEND 
NSTMT,NSTMTX,NSTMTH,NC0M,LC0M,I0VFL,C0M(2000) 
KIO , I  NUN  IT , I  SCR AT ,KBDOUT ,KRDKNT , LLIST 
NRC,RC(12600) 

IARGS(IOO) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW(NCOL 


COMMON  /BLOCKA/ 
COMMON  /BLOCKB / 
COMMON  /BLOCKC/ 
COMMON  /BLOCRC/ 
COMMON  /BLOCKD / 
1ARGS,VWXYZ(8) ,NERROR 
DIMENSION  ARGS(IOO) 
EQUIVALENCE  (ARGS ( 1 ), RC ( 12501 ) ) 
COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG 

COMMON /HEADER /NOCARD (80) , ITLE (60 ,6) , LNCNT , I  PRINT ,NPAGE , I  PUNCH 
THE    FOLLOWING    CARDS  ARE    NEDDED    ONLY    FOR  TAPE  OPERATIONS 
COMMON  /TAPE/  NAME4 (2 ) (NTPCT , IPUNCP , I  NUN  IP , L1TP 

DATA  IBLANK/1H  /,LETSG0/-1/ 

THIS  IS  THE  MAIN  OMNITAB  PROGRAM 


SUBROUTINES  CALLED  BY  THIS  PROGRAM.. 

SETUP , INPUT , ERROR , STMT , NNAME , AARGS , ASTER , SETQ , READQ , STORE , XECUTE 
AERR ,XOMNIT ,XFORMT , LOOKUP 


MOD  =  1    INTERPRETIVE  MODE 

=  2    DATA  MODE  (READ  SET) 

=  3    STORAGE  MODE  (BETWEEN  BEGIN  AND  FINISH) 

=4    IMPLIED  STORAGE  MODE  (STATEMENT  NUMBER  GIVEN 


OMN 
OMN 

*OMN 
OMN 
OMN 
OMN 
OMN 

NOMN 
OMN 


10 
20 
30 
40 
50 
60 
70 
80 
90 


0  =    0,     1  =    1,  ETC.,  9  =    9,  A  =  10,  B  =  11,  ETC,  Z=  35,   /  =  36 
.  =  37,  -  =  38,  +  =  39,   *  =  40,    (  =  41,    )  =  42,    ,  =  43 
BLANK  =44,  =  =  45 ,  $  AND  OTHERS  =  46 

CALL  SETUP 

IF  (MODE . EQ . 3 )  NSTMT=NSTMT+10 

IF  (M0DE.EQ.4)  M0DE=1 

NAME(1)=0 

NAME(2)=0 

NAME(3)=0 

NAME(4)=0 

NARGS=0 

J=0 

CHECK  FOR  ACCUMULATED  ERRORS  DURING  LAST  EXECUTED  COMMAND 

CALL  AERR  (0) 
CALL  INPUT 

SCANNING  BEGINS  WITH  THE  THIRD  CHARACTER.  THE  FIRST  TWO  ARE  DUMMY 
TO  KEEP  THE  PROGRAM  OUT  OF  TROUBLE.  SCANNING  TERMINATES  WITH  A  $ 
A  $  HAS  BEEN  PLANTED  IN  THE  (KRDEND+1 ) -TH  POSITION. 

M=2 
M=M+1 
K-KARD (M) 

IF  (K.GE.36)  IF  (K-46)  45,40,30 


OMN  100 
OMN  110 
OMN  120 
OMN  130 
OMN  150 
OMN  160 
*OMN  170 
OMN  180 
OMN  190 
OMN  200 
OMN  210 
OMN  220 
OMN  230 
OMN  240 
OMN  250 
OMN  260 
OMN  270 
OMN  280 
OMN  290 
OMN  300 
OMN  310 
OMN  320 
OMN  330 
OMN  340 
OMN  350 
OMN  360 
OMN  370 
OMN  460 
OMN  470 
OMN  480 
OMN  490 
OMN  500 
OMN  510 
OMN  520 
OMN  530 
OMN  540 
OMN  550 
OMN  560 
OMN  570 
OMN  580 
OMN  590 
OMN  600 
OMN  610 
OMN  620 
OMN  630 
OMN  640 
OMN  650 
OMN  660 
OMN  670 
OMN  675 
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IF  (K.GE.10)  GO  TO  60  OMN  680 

C  OMN  690 
C         A  NUMBER  IS  THE  FIRST  ALPHANUMERIC  CHARACTER  ENCOUNTERED,  ERROR  IFOMN  700 

C          IN  MODE  3  OMN  710 

C  OMN  720 

CALL  OUTPUT  OMN  730 

IF   (M0DE.NE.3)  GO  TO  50  OMN  740 

35        CALL  ERROR  (2)  OMN  750 

GO  TO  20  OMN  760 

40        IF   (MODE . NE . 4 )  CALL  OUTPUT  OMN  770 

GO  TO  10  OMN  780 

C         CHECK  FOR    *  OR  '  OMN  790 

45        IF   (K-40)  30,190,30  OMN  800 

50        CALL  STMT  (NSTMT)  OMN  810 

IF   (KARG.NE.O)   IF   (MODE-2)  35,185,35  OMN  815 

C  OMN  820 
C          IF  AN  ILLEGAL  STATEMENT  NUMBER  WAS  FOUND,  KARG  =  1  (KARG  =  0  IF      OMN  830 

C         LEGAL)  OMN  840 

C  OMN  850 

M0DE=4  OMN  860 

C  OMN  870 

C         M  IS  POINTING  AT  THE  FIRST  LETTER  ON  THE  CARD,  ASSEMBLE  NAME.          OMN  880 

C  OMN  890 

60        CALL  NNAME  (NAME (1) )  OMN  900 

C  OMN  910 

C  OMN  920 

C         CHECK  THE  FIRST  NAME  FOR  SPECIAL  NAMES...  OMN  930 

C         OMNITAB,  FORMAT,  NOTE,  FOOTNOTE,  HEAD, TITLE  OMN  940 

C  OMN  950 

C         OMNITAB  OMN  960 

C  OMN  970 

IF  (NAME(l) .NE. 11300. OR. NAME(2) .NE .7102) IF (LETSGO)  65,67,67  OMN  975 

C  OMN  980 

C          IF  NOT  THE  FIRST  OMNITAB  CARD,  WRITE  EOF  RECORD.                               OMN  990 

C  0MN1000 

IF(LETSG0.NE. (-1) )  WRITE  (ISCRAT,390)  0MN1010 

LETSG0=LETSG0+1  0MN1020 

65        CALL  XOMNIT  (LETSGO)  0MN1030 

IF (LETSGO .NE . (-1) )  GO  TO  10  0MN1040 

LETSGO=0  0MN1050 

C  0MN1060 

C         FINISH  0MN1070 

C  0MN1080 

67        IF  (NAME(l) .NE. 4631. OR. NAME(2) .NE. 7082)  GO  TO  70  0MN1090 

M0DE=1  OMN1100 

GO  TO  40  0MN1110 

C  0MN1120 

C         FORMAT  OMNI 130 

C  0MN1140 

70        IF  (MODE .NE .4)  CALL  OUTPUT  0MN1150 

IF  (NAME(l) .NE. 4797. OR. NAME(2) .NE. 9524)  GO  TO  90  0MN1160 

CALL  XFORMT  0MN1170 

80        IF  (MODE .GE . 3 )  CALL  ERROR  (202)  0MN1180 

IF  (MODE .NE .3 )  M0DE=1  0MN1190 

GO  TO  10  0MN1200 

C  0MN1210 

C         NOTE  0MN1220 

C  0MN1230 

90        IF  (NAME ( 1 ) .NE. 10631. OR. NAME(2) .NE.3645)  GO  TO  100  0MN1240 
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K=KARD (M)  0MN1243 

IF  (K.EQ.l .0R.K.EQ.2)  GO  TO  95  OMN1245 

IF  (NPAGE.EQ.O)  CALL  PAGE  (0)  0MN1247 

WRITE  (IPRINT,400)   (NEWCD ( 1-2 ) , I=M, 82 )  0MN1250 

LNCNT=LNCNT+1  0MN1260 

GO  TO  80  0MN1270 

95        CALL  NOTEPR  (K)  0MN1273 

GO  TO  80  0MN1275 

C  0MN1280 

C         HEAD  0MN1290 

C  0MN1300 

100      IF  (NAME(l) .NE .5968 .OR .NAME (2) .NE.2916)  GOTO  110  0MN1310 

CALL  XHEAD  0MN1320 

GO  TO  80  0MN1330 

C  0MN1340 

C         TITLES.      TITLEX  =  TITLES ,  TITLEY  =  TITLE6  0MN1350 

C  0MN1360 

110      IF   (NAME(l) .NE. 14843)  GO  TO  160  0MN1370 

C         CHECK  NAME  TITLE  0MN1380 

IF  (NAME(2) .EQ.8883)  GO  TO  120  0MN1390 

C         CHECK  TITLEX,  TITLEY  0MN1400 

K=5  0MN1410 

M=M+1  0MN1420 

IF (NAME (2) .NE .8908)   IF   (NAME (2 ) -8907 )  160,130,160  0MN1425 

K=6  0MN1430 

GO  TO  130  0MN1440 

120      K=KARD (M)  0MN1450 

IF(K.GE.1.AND.K.LE.4)  GO  TO  130  0MN1460 

CALL  ERROR  (209)  0MN1470 

K=l  0MN1480 

130      MM=MIN0(M+59,81)  0MN1490 

DO  140  1=1,60  0MN1500 

140      ITLE ( I ,K)=IBLANK  0MN1510 

1=1  0MN1520 

DO  150  MA=M , MM  0MN1530 

ITLE (I ,K)=NEWCD (MA-1 )  0MN1540 

150      1=1+1  0MN1550 

GO  TO  80  0MN1560 

C  0MN1570 

C  STOP  0MN1580 

C  0MN1590 

160      IF  (NAME(l) .NE. 14406. OR. NAME(2) .NE. 11664)  GOTO  170  0MN1600 

WRITE  (ISCRAT,390)  0MN1610 

CALL  XSTOP  0MN1620 

STOP  0MN1630 

C  0MN1640 

C         M  IS  POINTING  AT  THE  FIRST  NON-LETTER  AFTER  NAME.  LOOK  FOR  0MN1650 

C         POSSIBLE  NAME  QUALIFIER  OR  ARGUMENTS  OR  END  OF  CARD.  0MN1660 

C  0MN1670 

170      K=KARD(M)  0MN1680 

IF  (K.LT.36)  IF  (K-10)  190,175,175  0MN1685 

IF  (K.EQ.40)  GO  TO  190  0MN1690 

IF  (K.EQ.46)  GO  TO  320  0MN1700 

M=M+1  0MN1710 

GO  TO  170  0MN1720 

C  0MN1730 

C         A  LETTER  FOUND,  ASSEMBLE  SECOND  NAME  (COMMAND  QUALIFIER).  0MN1740 

C  0MN1750 

175      CALL  NNAME  (NAME (3))  0MN1760 
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CHECK  SPECIAL  CASE  OF  NAMES  M(XAX'),  M(X'AX),  M(XX'),  M(X'X) 

SKIP  ONE  CHARACTER  (')   IF  FIRST  NAME  =(M  ) 

THE  FOLLOWING  CARD  IS      NEEDED  ONLY  FOR  TAPE  OPERATIONS 

IS  NAME (3)  EQUAL  TO  TAP  AND  NAME (4 )=E 

IF   (NAME(3) .NE. 14623 .OR. NAME(4) .NE. 3645)  GO  TO  180 

CALL  TAPOP 

GO  TO  190 


0MN1770 
OMN1780 
0MN1790 
0MN1800 
0MN1810 
0MN1820 
0MN1830 
0MN1840 
0MN1850 
0MN1860 


IF  (NAME ( 1 ) .EQ.9477 
GO  TO  190 


M=M+1 


0MN1870 
0MN1880 
0MN1890 
0MN1900 
0MN1910 
0MN1920 
0MN1930 
0MN1940 
0MN1950 
0MN1960 
0MN1965 
0MN1970 

NUMBER  FOUND,  CONVERT  ARGUMENT.  IF  KARG  RETURNED  =  0,  NUMBER  IS  0MN1980 
INTEGER, IF  KARG  =  1,  NUMBER  IS  FLOATING  POINT,  IF  KARG  =  -1,  ERR0R0MN1990 

0MN2000 

CALL  AARGS 

IF  (KARG)  10,230,220 
ARGTAB (J )=0 . 


SCAN  FOR  ARGUMENTS  AND  END  OF  CARD 

M=3 

J=J+1 

GO  TO  210 

M=M+1 

K=KARD (M) 

IF   (K.GE.10)   IF   (K-40)  200,255,315 


ADD  A  BIAS  OF  8192  THEN  CHECK  THAT  IT  IS 


0MN2010 
0MN2020 
OMN2030 
0MN2040 
OMN2050 
0MN2060 
OMN2070 
0MN2080 
0MN2090 
0MN2100 
0MN2110 
0MN2120 
0MN2130 
0MN2140 
0MN2150 
0MN2160 
0MN2170 
0MN2180 
0MN2190 

IF  BRACKETED  BY  SINGLE  ASTERISKS,  QUANTITY  IS  TO  BE  USED  AS  A  0MN2200 
FLOATING  POINT  ARGUMENT. IF  BRACKETED  BY  DOUBLE  ASTERISKS,  QUANTITY0MN2210 
IS  TO  BE  TRUNCATED  AND  USED  AS  AN  INTEGER  ARGUMENT.  0MN2220 

0MN2230 

KARG=1  0MN2240 
M=M+1  0MN2250 
IF  (KARD(M) .NE.40)  GO  TO  260  0MN2260 
KARG=0  0MN2270 
M=M+1  0MN2280 
MS=M  0MN2290 
CALL  ASTER  0MN2300 

0MN2310 

THE  TERMINAL  ASTERISK(S)  HAVE  BEEN  CHECKED  TO  BE  THE  SAME  AS  THE  0MN2320 
INTITAL  SET  (IF  NO  ERROR)  AND  M  IS  POINTING  AT  THE  FIRST  CHARACTER0MN2330 
AFTER  THE  LAST  ASTERISK.  0MN2340 


J=J+1 
GO  TO  240 

ARGUMENT  IS  AN  INTEGER 
.GT.  0 

ARG=ARG+8192 . 

IF  (ARG.GT.O.)  GO  TO  240 

CALL  ERROR  (18) 

GO  TO  10 

ARGTAB (J )=ARG 

NARGS=NARGS+1 

GO  TO  190 

ASTERISK  FOUND,  CONVERT 
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c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 

270 
280 
290 


KARG  RETURNED  AS 


300 


310 

C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 

c 
c 
c 
c 


1  =  ERROR  FOUND 

2  =  FLOATING  POINT  CONSTANT,  Z.B. 

3  =  INTEGER  NAMED  VARIABLE,  Z.B. 

4  =  FL.  PT.  NAMED  VARIABLE,  Z.B. 

5  =  INTEGER  ROW-COLUMN,  Z.B. 

6  =  FL .  PT.  ROW-COLUMN,  Z.B. 

7  =  STRING  OF  ASTERISKS  Z.B. 


A  STRING  OF  THREE  OR  MORE  ASTERISKS  IMPLIES  -THRU- 
EXAMPLE.  . 


*  p  j  * 

**NRMAX** 
*NRMAX* 

*  *  3  40  *  * 

*  1  2  * 

*  *  * 


ERASE 
ERASE 


2  3  4 

*t»  T* 


12  13  14  15 

12  ***  16, 


16  20 
20 


PRINT  1  20  19  18  17  16  15  14 
PRINT  1,  20  ***  14 


IS  EQUIVALENT  TO 


IS  EQUIVALENT  TO 


GO  TO  (270,220,280,280,290,290,300),  KARG 
M=MS 

GO  TO  210 

ARGTAB (J )=-2 . *ARG-FLOAT (KARG-3 ) 
GO  TO  250 

ARGTAB(J)=-(ARG+8208. ) 

ARG2=ARG2+8192. 

IF  (KARG.EQ.6)  ARG2=-ARG2 

J=J+1 

ARGTAB (J )=ARG2 
GO  TO  250 

IF  (J.GT.O)  GO  TO  310 
CALL  ERROR  (211) 
GO  TO  210 
ARGTAB (J )=-l . 
GO  TO  190 


ARGTAB  SETUP 


IF  ENTRY 
TO  WHICH 


0MN2350 
0MN2360 
0MN2370 
0MN2380 
0MN2390 
0MN2400 
0MN2410 
0MN2420 
0MN2430 
0MN2440 
0MN2450 
0MN2460 
0MN2470 
OMN2480 
0MN2490 
0MN2500 
0MN2510 
0MN2520 
0MN2530 
0MN2540 
0MN2550 
0MN2560 
0MN2570 
0MN2580 
0MN2590 
0MN2600 
0MN2610 
0MN2620 
0MN2630 
0MN2640 
OMN2650 
OMN2660 
0MN2670 
0MN2680 
0MN2690 
0MN2700 
0MN2710 
0MN2720 
0MN2730 
0MN2740 


IF  ENTRY  .EQ.O,  THE  NEXT  ENTRY  IS  A  FLOATING  POINT  CONSTANT. 
IF  ENTRY  .LT.  0,  ARGUMENT  IS  A  VARIABLE.  SET  SIGN  POSITIVE  AND 
IF  ENTRY  .LT.  16,  IT  IS  A  NAMED  VARIABLE  REFERENCE  NUMBER 


.GT.  0,  IT  IS  AN  INTEGER  CONSTANT  (Z.B.  COLUMN  NUMBER) 
A  BIAS  OF  8192  HAS  BEEN  ADDED.     THIS  IS  TO  SAY  THAT  A 
NEGATIVE  INTEGER  ARGUMENT  MAY  NOT  BE  EXPLICITLY  GIVEN  OR  MODIFIED  0MN2750 
TO  BE  LESS  THAT  -8191.  0MN2760 

0MN2770 
OMN2780 
0MN2790 
0MN2800 
0MN2810 
0MN2820 
0MN2830 
0MN2840 
0MN2850 
0MN2860 
0MN2870 
0MN2880 

V,W,X,Y,Z,  ARE  FOR  PROGRAMMING  CONVENIENCE  ONLY  AND  DO  N0T0MN2890 
AFFECT  THE  OPERATION  OF  OMNITAB  0MN2900 

0MN2910 

IF  ENTRY  IS  EVEN,  CURRENT  VALUE  TO  BE  TRUNCATED  AND  USED  0MN2920 
AS  AN  INTEGER  ARGUMENT.  0MN2930 


IF 


2,3 
4,5 


NRMAX 
COLTOP 


6,7 
8,9 


V 
W 


10,11 
12,13 
14,15 


X 
Y 
Z 
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C  IF  ENTRY  IS  ODD.  THE  CURRENT  VALUE  IS  TO  BE  USED  AS  A  0MN2940 

C  FLOATING  POINT  ARGUMENT.  0MN2950 

C  0MN2960 
C                IF  ENTRY   .GT.  16,  IT  IS  A  WORKSHEET  REFERENCE  (ROW, COLUMN)  TO  0MN2970 

C  WHICH  A  BIAS  OF  8192.  HAS  BEEN  ADDED.  0MN2980 

C  ENTRY  -  8208  =  ROW  NUMBER  0MN2990 

C  ABS (NEXT  ENTRY)  =  COLUMN  NUMBER  TO  WHICH  A  BIAS  OF  8192.  0MN3000 

C  HAS  BEEN  ADDED.  0MN3010 

C  0MN3020 
C  IF  NEXT  ENTRY  IS  NEGATIVE,  WORKSHEET  CONTENTS  ARE  TO  BE  0MN3030 
C                       USED  AS  A  FLOATING  POINT  CONSTANT.     IF  +,  WORKSHEET  VALUE  OMN3040 

C  TO  BE  TRUNCATED  AND  USED  AS  AN  INTEGER  ARGUMENT.  0MN3050 

C  0MN3060 

C  0MN3070 

315      IF   (K.NE.46)  GO  TO  200  0MN3080 

C  0MN3090 

C        THE  TERMINATION  OF  CARD  FOUND  (  $  ENCOUNTERED)  0MN3100 

C  0MN3110 

320      IF  (J.EQ.O)  J=l  0MN3120 

IF  (MODE . NE . 2 .OR .NAME (1 ) .NE . 0 )  GO  TO  350  0MN3130 

C  0MN3140 
C          IN  INPUT  MODE  AND  NO  POSSIBLE  NAME,  RETURN  TO  SET  OR  READ  ROUTINE  0MN3150 

C  0MN3160 

330      CALL  EXPAND  (J , ARGTAB)  0MN3170 

IF  (ISRFLG.EQ.O)  GO  TO  340  0MN3180 

CALL  SETQ  0MN3190 

GO  TO  10  OMN3200 

340      CALL  READQ  0MN3210 

GO  TO  10  0MN3220 

C  OMN3230 

C         LOOK  UP  NAME  (AND  POSSIBLE  QUALIFIER)  IN  DICTIONARY.  RETURN  0MN3240 

C         COORDINATES  OF  ENTRY.  IF  LI  =  0,  NAME  NOT  FOUND  0MN3250 

C  0MN3260 

350      CALL  LOOKUP  0MN3270 

IF  (Ll.NE.O)  GO  TO  360  0MN3280 

IF  (MODE .EQ . 2 )  GO  TO  330  0MN3290 

CALL  ERROR  (1)  0MN3300 

GO  TO  10  0MN3310 

C  0MN3320 

C         NAME  FOUND  0MN3330 

C  0MN3340 

C  THE    FOLLOWING    CARDS  ARE    NEDDED    ONLY    FOR  TAPE  OPERATIONS  0MN3350 

C         STATEMENT  WAS    220  IF  (MODE .EQ . 2 )  M0DE=1  0MN3360 

360      IF  (MODE . EQ . 2 )  GO  TO  370  0MN3370 

Q  ****************************************************************  *  *0MN3  3  80 

IF  (MODE .EQ . 1 )  GO  TO  380  0MN3390 

CALL  STORE  (J)  0MN3400 

GO  TO  10  0MN3410 

C  THE    FOLLOWING    CARDS  ARE    NEDDED    ONLY    FOR  TAPE  OPERATIONS  0MN3420 

370      M0DE=1  0MN3430 

INUNIT=INUNIP  0MN3440 

Q  ************************************************************** 

380      CALL  EXPAND  (J, ARGTAB)  0MN3460 

CALL  XECUTE  0MN3470 

GO  TO  10  0MN3480 

C  0MN3490 

390      FORMAT  (1HZ,83X)  0MN3500 

400      FORMAT  (1X,80A1)  0MN3510 

END  0MN3520 
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SUBROUTINE  ONEWAY 

ONE 

10 

c 

VERSION    5.00     ONEWAY  5/15/70 

ONE 

20 

c 

ONE 

30 

c 

*********************************************************** 

40 

c 

OMNITAB  *  ONEWAY  STAT.  ANALYSIS. 

ONE 

50 

c 

WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS .  10/25/69. 

ONE 

60 

c 

ONEWAY  ANALYSIS  OF  DATA  IN  ++  WITH  TAG  IN  ++  STORE  IN  ++,++  

ONE 

70 

c 

TAG  NUMBERS  DIFFERENTIATE  BETWEEN  GROUPS 

ONE 

80 

c 

WHEN  TAG  IS  NON-POSITIVE  ZERO  WEIGHT  IS  GIVEN  TO  MEASUREMENTS 

ONE 

90 

c 

NUMBER  OF  GROUPS  MUST  BE  GREATER  THAN  1  AND  MUST  NOT  EXCEED  NLNTH20NE 

100 

c 

NRMAX  MUST  NOT  EXCEED  NLNTH1 

ONE 

110 

c 

SLOPE  IN  ANOVA  IS  ONLY  GIVEN  IF  FPROB  FOR  BETWEEN  IS  LESS  THAN  . 

100NE 

120 

c 

****************************************************************  *  *Qty£ 

130 

COMMON  /BLOCKD /  IARGS(IOO) , KIND (100) ,ARGTAB (100) , NRMAX ,NROW,NCOL , NONE 

140 

1ARGS,VWXYZ(8) ,NERROR 

ONE 

150 

COMMON  /BLOCRC/  NRC , RC  ( 12600 ) 

ONE 

160 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG 

ONE 

170 

DIMENSION  ARGS(IOO) 

ONE 

180 

EQUIVALENCE  (ARGS ( 1 ), RC  (12501 ) ) 

ONE 

190 

COMMON  /HEADER/  NOCARD (80 ) , ITLE (60 , 6 ) , LNCNT , IPRINT , NPAGE , IPUNCH 

ONE 

200 

COMMON  /SCRAT/  NS , NS2 , A ( 13500 ) 

ONE 

210 

COMMON  /ABCDEF /  L(48) 

ONE 

220 

EQUIVALENCE  (BLANK , L (45 )) ,   (SL0,L(22)),  (HIGH,L(18)) 

ONE 

230 

c 

NLNTH1  =  LENGTH  OF  ARRAYS  =  2700,  MUST  BE  CHANGED  IF  NS  CHANGED 

ONE 

240 

c 

5*NLNTH1  MUST  BE  LE  NS                   DIMENSION  A3 (NLNTHl ) 

ONE 

250 

DIMENSION  A2(2700),  A3(2700),  A4(2700),  A5(2700) 

ONE 

260 

EQUIVALENCE  (A2 (1 ) , A (2701 ) ) 

ONE 

270 

EQUIVALENCE  (A3 (1 ) , A (5401 ) ) ,   (A4  ( 1 ) , A (8101 ) )  ,   ( A5 ( 1 ) , A  ( 10801 ) ) 

ONE 

280 

c 

NLNTH2  =  LENGTH  OF  ARRAYS  =  540,  MUST  BE  CHANGED  IF  NS  CHANGED 

ONE 

290 

c 

10*NLNTH2  LE  NLNTHl                        DIMENSION  Bl (NLNTH2 ) 

ONE 

300 

DIMENSION  Bl(540),  B2(540),  B3(540),  B4(540),  B5(540),  B6(540), 

B70NE 

310 

1(540),  B8(540),  B9(540),  B10(540) 

ONE 

320 

EQUIVALENCE  (Bl (1 ) , A (1 ) ) ,   (B2 (1 ) , A (541 ) ) ,   (B3 (1 ) ,A (1081 ) )  ,  (B4(1),0NE 

330 

1A(1621)),    (B5(l) ,A(2161)) ,    (B6 ( 1 ) , A (2701 ) ) ,    (B7  (1 ) , A (3241 ) ) ,  (B8(10NE 

340 

2),A(3781)),    (B9(l) ,A(4321)) ,   (BIO ( 1 ) , A (4861 ) ) 

ONE 

350 

c 

ONE 

360 

c 

EXECUTION  TIME  CAN  BE  CONSIDERABLY  SHORTENED  USING  LESS  ACCURATE 

ONE 

370 

c 

VERSION  OF  FPPT. 

ONE 

380 

c 

ONE 

390 

c 

i|c  sfc          ^  +  :£  #  £  j|{  ^                  ^  #      #          sfc  s|e  ^ 

400 

c 

ONE 

410 

NLNTHl=NS/5 

ONE 

420 

NLNTH2=NLNTHl/5 

ONE 

430 

c 

ERROR  CHECKING 

ONE 

440 

IF  (NRMAX. GT. NLNTHl)  GO  TO  50 

ONE 

450 

IF  (NRMAX. EQ.O)  CALL  ERROR  (9) 

ONE 

460 

IF  (NARGS.EQ.6)  GO  TO  40 

ONE 

470 

IF  (NARGS . EQ . 2 .AND . L2 .EQ . 13 )  GO  TO  40 

ONE 

480 

IF  (NARGS .EQ . 2 . AND . L2 . EQ . 14 )  GO  TO  10 

ONE 

490 

IF  (NARGS. EQ. 3)  GO  TO  20 

ONE 

500 

CALL  ERROR  (10) 

ONE 

510 

RETURN 

ONE 

520 

10 

CALL  ERROR  (236) 

ONE 

530 

RETURN 

ONE 

540 

20 

DO  30  1=4,6 

ONE 

550 

IARGS(I)=IARGS(3)+1 

ONE 

560 

30 

KIND(I)=0 

ONE 

570 

NARGS=6 

ONE 

580 

40 

CALL  CHKCOL  (J) 

ONE 

590 
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i r   /  i  cn  n i   en  tci  in 
ir  (J.ty.u)  uu  iu  ou 

(\  ki  c    l  a  a 

UNt  600 

50 

LALL    tKKUK  til) 

nur  tin 
UNt  610 

60 

i  r   (MrDonD  Kir  t\  \  rn  Tn  cm 
lr    (NtKKUK . Nt . U )    UU    IU  51U 

n  ki  c   l  o  r\ 
UNt  620 

L 

MOVE  Y  AND  TAG  TO  SCRATCH  AREA 

MOVING 

TO 

BOTTOM  IF  TAG 

UNt  630 

A 

U 

NON-POSITIVE,  CONVERT  TAG  TO  INTEGER, 

COMPUTE  NZW  AND  K,  SET 

1  1 D     T     f\MC    L  A  ft 

Ur    1    UNt  640 

Ml  1  — T  ARG^ 111  1 

mil  —  1  HI\U J  ^  J.  ;  —  X 

ntir  ten 
UNt  6d0 

Ml  ?-T  ARG^  <  ?  )  1 

Alir     L  L  ft 

UIMt  660 

K-0 

UNt  6/U 

N7W-0 

1 1  L.  If — U 

n  k  i  c  l  o  ft 
UNt  boU 

DO  80  1=1  NRMAX 

HMt     L  ft  ft 

UNt  07U 

MO?— Ml  1  -i-T 

n  ki  c   ~i  r\  ft 
UNt  /UU 

Mn3— Ml  ?-i-T 

nur  il n 
UNt    / 1U 

TF    (RP(M031    GF   1    ni   GO  Tfl  7f) 

nur    7  o  ft 
UNt    /  £.[} 

NZW-NZW+1 

nKir  7 1 (\ 
UNt    1 3\i 

M01=NRMAX-NZW+1 

iiiv  Awimninn    ilia  ikt  a 

flNF    7  A.(\ 

A3 ( M01 }-RC ( MO 2 ) 

nur  7  c n 

UNt  /DU 

A  4  (Mm  \  —0  n 
m  *r  ^  vn\j  x  )  — \j  .  u 

n  KI  C     7  Lft 

UNt   / 6U 

GO  TO  80 

nwc  7 7 n 
UNt   / / U 

7  n 
/  u 

J=I-NZW 

flKJP  70A 

A3 (J )=RC (M02 ) 

nwF  7on 

A4 ( J i-AINT fRC (M03 ^+1  E-81 

UNt  oUU 

o  a 
BU 

K-MAX0  f  K  INT(A4fJl+l  0E-6n 

Alir     O  1  A 

UNt  810 

NZW-NRMAX-NZW 

UNt  Oil) 

IF   (NZW  LE  IO  GO  TO  50 

UNt  oJU 

IF  (K.LT.2)  GO  TO  50 

nwc  QAn 

IF  (K.GT.NLNTH2)  GO  TO  50 

n  ki  c  oca 
UNt  odO 

M34=NZW+1 

nwc  o l n 
UNt  B60 

p 
1/ 

COMPUTE  NI ,MEAN,S(R) , SETUP  MIN 

+  MAX, I  BAR 

FOR   T— 1  K 

nwc  o 7  a 
UNt  o/U 

DO  90  I=1,NLNTH1 

HKIC  oon 
UNt  ooU 

on 

7  u 

A(I)=0.0 

nwc  son 

UIVL  07U 

CALL  RANK0  (NZW , A3 ( 1 ) , A2 ( 1 ) , A5 ( 1 ) , A (49 ) ) 

nwc  onn 

A(49)=12.0*A(49) 

nWC  OTA 
UNt  7lU 

A(133)=NZW 

nwc  q o a 
UNt  7Z.U 

DO  100  1=1, NZW 

nwc   Q 1 A 
UNt  7JU 

M40=A4(I) 

nwc  od a 

B2(M40)=B2(M40)+1.0 

DNC  QRA 
U  N t  7jU 

B3(M40)=B3(M40)+A3(I) 

nwc  QAA 

UNt  70U 

B5 (M40)=B5 (M40 ) +A5 ( I ) 

ONC  Q7A 
UNt    7 / U 

B6(M40)=A3(I) 

nwc  QQA 

UNt  70U 

B7 (M40)=A3 (I ) 

nwc  QQA 

U  N  C    7  7  U 

A(21)=A(21)+A3 (I ) 

("IMF  1  AAA 

i  nn 

A(101)=A(101)+A4(I) 

nwc 1  A  1  A 

UllLlVJ  1U 

A(21)=A(21) /A(133) 

nwci at  a 

UIvLIUlU 

A(101)=A(101) /A(133) 

n  fil  C  1  A  1  A 

UN t 1 U i u 

DO  110  1=1, K 

nWC 1  Ad A 
UN  t  X  U*r  U 

IF   (B2(I) .GT.0.0)  B3 (I )=B3 (I ) /B2  (I ) 

nwc 1  A  K A 

UNtlUDU 

B8(I)=B3(I) 

nwc 1  AAA 
UN 1 1 U  O  U 

COMPUTE        MIN  ,  MAX  ,SD>S,SS,DF,MS,F,  FPR0B  ,  S  ( 1  /  NI )  ,  S  (N.I  **3 )  ,  S  (R 

*  *  5  / WnWC 1 A7  A 
£ / NUNt 1U / u 

no 

B9(I)=B2(I) 

nwc i a  o  a 
UNtluoU 

DO  120  1=1, NZW 

nwci AQA 

U  N  t  X  u  7  U 

M40=A4(I)+.0001 

ONF linn 

B6(M40)=AMIN1(B6(M40) ,A3 (I ) ) 

nNF 1 1 1  A 
UN t  X  X  X  U 

B7(M40)=AMAX1(B7(M40) #A3 (I ) ) 

nwFi i on 

UNC.  X  X  C  U 

B4 ( M40 ) =B4 ( M40 ) + ( A3 ( I ) -B3 ( M40 ) ) 

*  *  2 

nNF  1  1  A 
UN  1 1 X  j U 

A(1)=A(1)+(B3(M40)-A(21))**2 

nNC i i in 

UNt  X 1HU 

A(4)=A(4)+(A3 (I)-B3 (M40) )**2 

nwci i c a 

UilLll  Ju 

1  0  ft 

12U 

A(5)=A(5)+(A3(I)-A(21))**2 

nnic 1 1  aa 

UN t  X  X  O  U 

A(17)=0.0 

0NE1170 

A(22)=B3 (1) 

0NE1180 
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A(23)=B3(1) 
A(24)=FSQRT(B4(1)  ) 
A(25)=0 . 
A(26)=B6(1) 
A(27)=B7(1) 
A(48)=0 .0 
DO  150  1=1 ,K 

BIO  (I  )  =  (B2  {I )  *  (B2  (I  )-l  .0)  ) /B4  (I ) 

A(126)=A(126)+B10(I)*B3(I) 

A(127)=A(127)+B10(I) 

IF   (B2(I)-1.)  150,140,130 
130      B4(I)=FSQRT(B4(I) / (B2(I)-1.0) ) 

A(121)=A(121)+(B2(I)-1 .0)*FL0G(B4(I)*B4(I) ) 

A(131)=A(131)+1 . 

A(25)=AMAX1 (A(25) ,B4(I)) 

A(24)=AMIN1 (A(24) ,B4(I)) 

A(120)=A(120)+1.0/(B2(I)-1.0) 
140      A (2 )=A (2 ) +B2 ( I ) * (FLOAT ( I ) -A ( 101 ) ) * (B3 ( I ) -A (21 ) ) 

A(114)=A(114)+B2(I)* ( (FLOAT (I )-A (101) )**2) 

A(22)=AMIN1(A(22) ,B3(I) ) 

A(23)=AMAX1 (A(23) ,B3 ( I ) ) 

A(26)=AMIN1(A(26) ,B6(I)) 

A(27)=AMAX1 (A(27) ,B7 (I) ) 

A(17)=A(17)+B5(I)**2/B2(I) 

A(18)=A(18)+1 . /B2 (I ) 

A(48)=A(48)+(B3(I)-A(21))**2 

A(122)=A(122)+B4(I)**2 

A(129)=A(129)+B2(I)**2 
150  A(118)=A(118)+B2(I)**3 

A(126)=A(126)/A(127) 

A(2)=A(2)**2/A(114) 

A(3)=A(1)-A(2) 
C         DEGREES  OF  FREEDOM  FOR  ANOVA 

M1=K-1 

A(136)=FL0AT(M1) 
M2=l 
M3=K-2 
M4=NZW-K 
A(134)=FL0AT(M4) 
M5=NZW-1 
C         MEAN  SQUARES 

A(6)=A(1)/A(136) 
A(7)=A(2) /FLOAT (M2) 
A(8)=A(3) /FLOAT (M3) 
A(9)=A(4) /FLOAT (M4) 
A(10)=A(5) /FL0AT(M5) 
A(11)=A(6)/A(9) 

A(12)=A(7)/((A(3)+A(4))/(A(133)-2.)) 
A(13)=A(8)/A(9) 

CALL  PROB  (A (136) , FLOAT (M4),A(11),A(14)) 
CALL  PROB  (FLOAT (M2) , FLOAT (M4) ,A(12) ,A(15)) 
CALL  PROB  (FL0AT(M3) , FLOAT (NZW-2 ) ,A(13) ,A(16) ) 
C         COMPUTE  FOR  KRUSKAL-WALLIS  TEST 
A(117)=NZW* (NZW+1) 

A(17)=(12.*A(17) ) /A(117)-3.*FL0AT(NZW+1) 
A(102)=1.0-A(49)/FL0AT(NZW**3-NZW) 
A(17)=A(17) /A(102) 

A(106)=(FL0AT(NZW**3)-A(118) )/A(117) 

A(105)=FL0AT(2*Ml)-.4*FL0AT(3*K*M3+NZW*(2*K*(K-3)+l) ) /A (117) 
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0NE1710 
0NE1720 
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118)/5. 

0NE1780 

A(103)=A(136)* (A (136)* ( A ( 106 ) -A ( 136 ) )-A(105) )/  (  .5*A(105)* 

A(106))  0NE1790 

A (104)= (A (106) -A (136) )*A(103) /A (136) 

0NE1800 

A(19)=A(17)* (A (106) -A (136) ) / ( A ( 136 ) * (A ( 106 ) -A ( 17 ) ) ) 
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JuR  1     ADMr\    rUI\    WlU  LI  IrLL    L- U  Wlr  rt  r\  1  jlUrij  Ur 

MF  AKK 
WIL  A  No 

0NE199C 

nn  i ao  T— i  mi 

uu   iou   i — i , mi 

a  ii  r  A  A  A  A 

ONE2000 

M37— k  T 

0NE2010 

nn  i  ao   i—i  mi 7 

UU    IOU    J — 1 # m3 1 

A  M  IT  O  ft  O  A 

ONE2020 

T  F    rRg/  h    IF    RQ  M  •  1  \  \    pfl   Tfl  un 
lr     lDO(,J;.Lt.DO(J+l);    vjU    I  U  loll 

ONE2030 

A  M  1  5  \  O  Q  /   |  \ 

A ) =DO ( J  ; 

A  ii  r  o  r\  >•  a 

ONE2040 

DO  /  1  \     DO  /  1  ,  1  \ 
Do  (  J  )  =DO  (  J+I  J 

A  ft!  r~  A  A  C  A 

ONE2050 

do  i  |,i  \ _A  n  l  1  \ 
DO  \ J  +1 ) =A (113  ) 

Aiir  i  a  /  a 

ONE2060 

A/1U\  — RQ  1  1  1 

A  11  r  ATA 

ONE2070 

DQ / 1 \  DQ / I , 1 \ 

D7 { J ) =D7 I J+l J 

All  T  1  A  fl  A 

ONE2080 

R0  /  1  j.1  1  —A  inn 

D  7  \  J  +  X  )  — M  (  X  X  j  ) 

A  11  f*  A  AAA 

0NE2090 

CONTINUE 

Aiirn  A/\ 

ONE2100 

PAII     FPPT    /A/iui    FinAT(  MA  1      nc  amhu 
l/HLL    rrrl     (A  (  1JO  )  ,r  LUA  1  \  Wit  J  ,  .  U3  ,  A  ^  11D  )  J 

AIICM  t  ft 

UNtZllO 

A  /  1  1  A  \  A  (%  1  \  *  FCfiPT  1  A  /  1  %  A  \  *  A  /  1  1  C  1  1 

A  ^  i 1 0 ; =A \ 3  X )    rjyKI  (A(IJO)    A  ^ 1 13  J  ; 

rtfcir  a  i  Aft 

ONE2120 

TFCTQ    FOR    UinMnPFWFTTV    OF  UAPTAMPFC 
1  l  j  1  j    FUR    nU  WlU  ulNlI  1  1    Ur  VAK1ANUC.O 

ftlirAi  Oft 

UNt2130 

A  /  ci  \     /  A  I1C  \  *A  nc  \  \  /  A  /  i  m 
A(Di)  =  (A(£b)    A(^:>)  )  j  S\(Xil) 

UNLZ 140 

A(l23)  =  AINT  (A(l33)/FL0AT(K)-0.5) 

PAII     PPDR     I A  1 1  0 1 1     A/lUltfAMll  1     1     \  (A 
uALL   rKUD    (A  ( 1/ J  )  ,  A  (  XC.3  )    (H  (1.3 1 )  —  1  .  )  ,  ( A 

AIIC  1  1  C  ft 

UNL2150 

(lil)-l . )   A ( b 1 ) / ( 1 

.  -A (51 ) ) ,0NE2155 

1  A(52)) 

UNLZloO 

Aiir  a  i  /  c 

0NE2165 

IF  (A(52)  .GT.l . )  A(52)  =  l .0 

UNtZ 170 

A(57)=(A(25) /A(24) )**2 
A(121)=A(134)*FL0G(A(9) )-A(121) 

AIIPO  1  Aft 

UNLZloO 

Alien  oa 
UNLZ190 

A(124)=(A(120)-1 .0/A(134) ) / (3 .*A(136) ) 
A(125)=(A(131)+1 . ) / (A(124)*A(124) ) 

Ak|  C  O  O  A  A 

UNtZ  Z  00 

AllCOOl  A 

UNcZZ 10 

A(53)=(A(125)*A(121) ) / ( (A(131)-l .0)* (A (125) / ( 1 . 0-A ( 124 ) +2 

a  ik  /  i  ic  \  ftllCi'i  Oft 

. 0 / A  ( 125 ) UNL2220 

1)-A(121) ) ) 

UNt2Z30 

CALL  PR0B  (A(131)-1.0,AINT(A(125)+.5),A(53),A(54)) 

UNt2240 

A (130)= (A (133) -A (129) /A (133) ) /A (136) 

UNt2250 

A(47)=(A(6)-A(9))/A(130) 

0NE2260 

COMPUTATIONS  ARE  NOW  COMPLETE  ************************************QNE2270 

M0=L2-12 

0NE228C 

GO  TO  (170,480) ,  M0 

0NE2290 

AUTOMATIC  PRINTING  WHEN  L2=13 

0NE2300 

FORMAT  STATEMENTS 

0NE2310 

CALL  PAGE  (4) 

0NE2320 

PRINT  AN0VA 

0NE2330 

WRITE  ( IPRINT , 520 ) 

0NE2340 

202 


180 


190 


200 


210 


220 


230 


240 
250 
260 


WRITE  ( IPRINT , 530  )  Ml , A ( 1 ) , A (6 ) , A ( 11 ) , A ( 14  ) 

IF  (K.LT.3)  GO  TO  180 

IF  (A(14) .GE .  .10)  GO  TO  180 

WRITE  (IPRINT, 540)  M2 , A (2 ) , A (7 ) , A ( 12 ) , A ( 15 ) 

WRITE  ( IPRINT ,550)  M3  ,  A  (3  )  ,  A  (8  )  ,  A  ( 13 )  ,  A  ( 16 ) 

WRITE  (IPRINT, 560)  M4,A(4),A(9) 

WRITE  (IPRINT,570)  M5,A(5) 

PRINT  KRUSKAL-WALLIS  TEST 

WRITE  (IPRINT, 580)  A(17),A(20) 

PRINT  ESTIMATES 

WRITE  (IPRINT.590) 

DO  220  1=1, K 

A(107)=BLANK 

A(108)=BLANK 

IF  (B2(I)-1.0)  220,190,190 
IF  (B3(I) .LE.A(22))  A(107)=SL0 
IF  (B3(I) .GE.A(23))  A(107)=HIGH 
IF   (B4(I) .LE.A(24))  A(108)=SL0 
IF  (B4(I) .GE.A(25))  A(108)=HIGH 


0NE2350 
0NE2360 
0NE2370 
ONE2380 
0NE2390 
0NE2400 
0NE2410 
0NE2420 
0NE2430 
0NE2440 
0NE2450 
0NE2460 
0NE2470 
0NE2480 
0NE2490 
0NE2500 
0NE2510 
0NE2520 
0NE2530 
0NE2540 
0NE2550 
0NE2560 
0NE2570 
0NE2580 
0NE2590 
ONE2600 
0NE2610 


270 


280 


(B3(I) .GE.A(23)) 
(B4(I) .LE.A(24)) 
(B4(I) .GE.A(25)) 
M8=B2(I) 

IF   (M8-1)  220,200,210 

WRITE  (IPRINT, 610)   I , M8 , B3 ( I ) , A ( 107 ) , B6 ( I ) , B7 ( I ) ,B5 ( I ) 
GO  TO  220 

A(109)=B4(I)/FSQRT(B2(I)) 
CALL  TPCTPT  (FLOAT (M8-1 ) ,A (112 ) ) 
A(110)=B3(I)-A(109)*A(112) 
A(111)=B3(I)+A(109)*A(112) 
WRITE  (IPRINT, 600)   I , M8 ,B3 ( I ) , A ( 107 ) , B4 ( I ) , A ( 108 ) , A ( 109 ) , B6 ( I ) ,B7 (0NE2620 

II) ,B5(I) ,A(110) ,A(111)  0NE2630 

CONTINUE  0NE2640 
WRITE  (IPRINT, 620)  NZW, A (21 ) , A (26 ) , A (27 ) , A (31 ) , A (34 ) , A (41 ) , A (44 ) ,A0NE2650 

1 (32) ,A(35) ,A(42) ,A(45) ,A(33) ,A(36) ,A(43) ,A(46)  0NE2660 

COMPUTE  AND  PRINT  FOR  MULTIPLE  COMPARISONS  0NE2670 

IF   (A(14)-0.10)  230,450,450  0NE2680 

IF  (M4.LT.4)  GO  TO  340  0NE2690 

WRITE  (IPRINT, 630)  ONE2700 

NEWMAN-KEULS-HARTLEY  0NE2710 

WRITE  (IPRINT, 640)  0NE2720 

J=l  0NE2730 

M28=0  0NE2740 

I=K  0NE2750 

IF   (I-M28)  330,330,260  0NE2760 

IF  (I  .EQ.J)  GO  TO  280  0NE2770 

A(135)=ABS(B8(I)-B8(J) )  0NE2780 

MANDEL  APPROXIMATION  TO  PERCENT  POINT  OF  STUDENTIZED  RANGE  0NE2790 

A (137 )=I-J+1  0NE2800 

RX=-. 283917+2 .63532* (A ( 134 )-l . 00123 ) ** (-.95862)  ONE2810 

Ul=-. 314115+2 .38301* (A ( 134 ) -1 . 03428 )**(-. 864005 )  ONE2820 

U2=3.65961*Ul**2-1.00891*Ul-0. 166346  0NE2830 

C=2 .3849867-2. 9051857* (A (137) -0.57583164)** (-.069648109)  0NE2840 

Vl=l .30153-1 .95073* (A ( 137 )+. 394915 ) ** (-.139783)  0NE2850 

V2=4.72863*Vl**2+0. 40427 l*Vl-0. 135104  0NE2860 
A ( 119 )=6. 15075+4. 441409*RX+6.7514569*C+7 .467 1282*U1*V1-.157537*U2*0NE2870 

1V2  0NE2880 

A(119)=A(119)*FSQRT( .5* (1 .0/B9(I)+l .0/B9(J) ) )*A(31)  0NE2890 

IF  (A(135)-A(119) )  280,280,270  0NE2900 

1=1-1  0NE2910 

GO  TO  250  0NE2920 

IF  (J.EQ.l)  GO  TO  310  ONE2930 
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IF   (J-M28)  290,290,300 
290      WRITE   (IPRINT  ,670  ) 

GO  TO  310 
300      WRITE  (IPRINT, 680) 

310      WRITE  (IPRINT, 660)    (B8 (M29 ) , M29=J , I ) 

IF   (I-K)  320,340,340 
320  M28=I 
330  J=J+1 

GO  TO  240 
C         SCHEFFE  METHOD 
340      WRITE   (IPRINT, 650) 

J=l 

M28=0 
350  I=K 

360      IF   (I-M28)  440,440,370 
370      IF  (I.EQ.J)  GO  TO  390 

A(135)=ABS(B8(I)-B8(J) ) 

A(119)=A(116)*FSQRT(1 .0/B9 (I )+l .0/B9(J) ) 

IF   (A(135)-A(119) )  390,390,380 
380  1=1-1 

GO  TO  360 
390      IF  (J.EQ.l)  GO  TO  420 

IF   (J-M28)  400,400,410 
400      WRITE   (IPRINT, 670) 

GO  TO  420 
410      WRITE  (IPRINT, 680) 

420      WRITE  (IPRINT, 660)   (B8 (M29 ) , M29=J , I ) 

IF   (I-K)  430,450,450 
430  M28=I 
440  J=J+1 

GO  TO  350 
450      IF   (A(131) .LT.2.0)  GO  TO  480 

WRITE   (IPRINT, 690)  A  (51 ) , A (52 ) , A (53 ) , A (54 ) , A ( 57 ) 

IF  (A(52) .GT. .10.AND.A(54) .GT. .10)  GO  TO  470 

DO  460  1=1, K 

A(55)=A(55)+B10(I)*(B3 ( I )-A (126 ) )**2 
A(128)=A(128)+(1.-B10(I)/A(127))**2/(B2(I)-1 . ) 
A(128)=(FL0AT(K**2)-1 . ) / (3 . *A (128) ) 

A (55)= (A (55) /FLOAT (Ml) ) / (1 .+(2 . *FLOAT (M3 ) ) / (3 .*A(128) ) 
CALL  PROB  (FLOAT (Ml) ,AINT(A(128)+.5) ,A(55) ,A(56)) 
WRITE  (IPRINT,700)  A(55),A(56) 
WRITE  (IPRINT, 710)  A(47) 

AUTOMATIC  PRINTOUT  IS  FINISHED  -  NOW  STORE  RESULTS  *** 

IF  (NARGS.EQ.2)  GO  TO  510 
M13=IARGS(3) 
M14=IARGS(4) 
M15=IARGS(5) 
M16=IARGS(6) 
DO  500  1=1, K 
C         DONT  STORE  IF  N=0 

IF  (B2(I) .LE.O.O)  GO  TO  490 
C  TAG 

RC(M13)=I 
C  N 

RC(M14)=B2(I) 
C  XBAR 

RC(M15)=B3(I) 
C         STANDARD  DEVIATION 


460 


470 

C 

C 

480 


ONE2940 
ONE2950 
0NE2960 
ONE2970 
0NE2980 
0NE2990 
0NE3000 
0NE3010 
ONE3020 
ONE3030 
0NE3040 
0NE3050 
0NE3060 
0NE3070 
0NE3080 
0NE3090 
0NE3100 
0NE3110 
0NE3120 
0NE3130 
0NE3140 
0NE3150 
0NE3160 
0NE3170 
ONE3180 
0NE3190 
0NE3200 
0NE3210 
0NE3220 
0NE3230 
0NE3240 
0NE3250 
0NE3260 
0NE3270 
0NE3280 
0NE3290 
0NE3300 
0NE3310 
)  0NE3320 
0NE3330 
ONE3340 
0NE3350 

0NE3370 
0NE3380 
0NE3390 
0NE3400 
0NE3410 
0NE3420 
0NE3430 
0NE3440 
0NE3450 
0NE3460 
0NE3470 
0NE3480 
0NE3490 
0NE3S00 
0NE3510 
0NE3520 
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RC(M16)=B4(I)  0NE3530 
490      M13=M13+1  0NE3540 
M14=M14+1  0NE3550 
M15=M15+1  0NE3560 
500      M16=M16+1  0NE3570 
510      RETURN  0NE3580 
C  0NE3590 
C  0NE3600 
520      FORMAT   (/ / ,48X , 20HANALYSI S  OF  VARIANCE/ / 17X , 6HS0URCE , 14X , 4HD  .  F  ., 4X0NE3610 
1(14HSUM  OF  SQUARES, 5X,12HMEAN  SQUARES , 9X , 7HF  RATIO, 4X,7HF  PROB./)  0NE3620 
530      FORMAT  (17X , 14HBETWEEN  GROUPS , 5X , 14 , 1P2E18 . 6 , 4X , OPFll .  3  ,  F10  . 3 )  0NE3630 
540      FORMAT  (20X , 5HSL0PE , 14X , 14 , 1P2E18 . 6 , 3X , OPFll . 3  , F10  . 3 )  0NE3640 
550      FORMAT  (20X , 16HDEVS .  ABOUT  LINE , 3X , 14 , 1P2E18  . 6 , 3X , OPFll . 3  , F10  . 3 )  0NE3650 
560      FORMAT   (17X , 13HWITHIN  GROUPS , 6X , 14 , 1P2E18 . 6 )  0NE3660 
570      FORMAT   (17X , 5HT0TAL , 14X , 14 , 1PE18  . 6  /  / )  0NE3670 
580      FORMAT  (11X ,65HKRUSKAL-WALLIS  RANK  TEST  FOR  DIFFERENCE  BETWEEN  GR00NE3680 
1UP  MEANS  *  H  =,0PF9.3,10H,  F  PROB  =,F6.3,10H  (APPROX.)/)  0NE3690 
590      FORMAT  (55X , 9HESTI MATES // IX , 5HGR0UP , 5X , 3HN0 . , 6X , 4HMEAN , 7X , 11HWITHI0NE3700 
IN  S.D. ,2X,12HS.D.  OF  MEAN , 5X , 7HMINIMUM, 7X , 7HMAXIMUM, 6X , 4HS (R ) , 4X , 20NE37 10 
23H95PCT  CONF  INT  FOR  MEAN/)  0NE3720 
600      FORMAT  ( IX , 14 , 18 , 1PE14 . 5 , Al , E13 . 5 , Al , E13 . 5 , 2E14 . 5 , 0PF9 . 1 , 1PE13 . 5 , 30NE3730 
1H  T0.E12.5)  0NE3740 
610      FORMAT  (IX , 14 , 18 , 1PE14 . 5 , Al , 3X , 24H  ESTIMATE  NOT  AVAILABLE  , 1P2E14 . 0NE3750 
15  0PF9  1  3X  2 5H* ******** *  jo     **********\  0NE3760 
620      FORMAT  ( / , IX , 5HT0TAL , 1 7 , 1PE14 . 5 , 28X , 2E14 . 5 /7X , 20HFIXED  EFFECTS  M0D0NE3770 
1EL  ,2E14.5,37X,E13.5,3H  TO , E12 . 5 /7X , 20HRAND0M  EFFECTS  MODEL ,, 2E14 . 0NE3780 
25,37X,E13 .5,3H  TO , E12 . 5 /7X , 14HUNGR0UPED  DATA , 6X , 2E14 . 5 , 37X , E13 . 5 , 30NE3790 
3H  T0,E12.5/)  0NE3800 
630      FORMAT  (IX , 120HPAIRWI SE  MULTIPLE  COMPARISON  OF  MEANS.     THE  MEANS  A0NE3810 
IRE  PUT  IN  INCREASING  ORDER  IN  GROUPS  SEPARATED  BY  *****.     A  MEAN  I0NE3820 
2S     /120H  ADJUDGED  NON-SIGNIFICANTLY  DIFFERENT  FROM  ANY  MEAN  IN  THE0NE3830 
3  SAME  GROUP  AND  SIGNIFICANTLY  DIFFERENT  AT  THE  .05  LEVEL  FROM  /1200NE3840 
4H  ANY  MEAN  IN  ANOTHER  GROUP.     *****  *****  INDICATES  ADJACENT  GR0UP0NE3850 
5S  HAVE  NO  COMMON  MEAN.  )  0NE3860 

640      FORMAT  ( /3X , 89HNEWMAN-KEULS  TECHNIQUE,  HARTLEY  MODIFICATION.  (APPR0NE3870 
10XIMATE  IF  GROUP  NUMBERS  ARE  UNEQUAL.))  ONE3880 
650      FORMAT  ( /3X , 18HSCHEFFE  TECHNIQUE.)  ONE3890 
660      FORMAT  (3X , 9  ( 1PE12 . 5  ,  1H  , ) )  0NE3900 
670      FORMAT  (6X,5H*****)  0NE3910 
680      FORMAT  (3X,11H*****  *****)  0NE3920 
690      FORMAT  (/,36H  TESTS  FOR  HOMOGENEITY  OF  VARIANCES . /7X , 13HC0CHRAN , S  0NE3930 
1C  =31H  MAX.  VARIANCE/SUM(VARIANCES)  =,F6.4,5H,  P  =,F6.3,10H  (APPR00NE3940 
2X. ) /7X , 16HBARTLETT-B0X  F  =,F9.3,5H,  P  = , F6 . 3 /7X , 37HMAXIMUM  VARIANC0NE3950 
3E  /  MINIMUM  VARIANCE  =,F10.3)  0NE3960 
700      FORMAT  (7X , 70HAPPR0X  BETWEEN  MEANS  F-TEST  IN  PRESENCE  OF  HETER0GEN0NE3970 
1E0US  VARIANCE.  F  =,F8.3,5H,  P  =,F6.3)  0NE3980 
710      FORMAT  ( / , IX , 35HM0DEL  II  -  COMPONENTS  OF  VARIANCE.   /7X , 29HESTIMATE0NE3990 
1  OF  BETWEEN  COMPONENT , 1PE15 . 7 )  0NE4000 
END  0NE4010 
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SUBROUTINE  OPONE  (N , M, MX ,NX ,ND2 , ND3 , ND19 , B , SSQ , IX )  OPO  10 

C         VERSION    5.00         OPONE           5/15/70  OPO  20 

C         SUBROUTINE  TO  PRINT  PAGE  1  OF  POLYFIT  AND  FIT  OPO  30 

C         *****  QPO  40 

C         WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS .       10/14/69.  OPO  50 

C0MM0N/BL0CRC/NRC,RC(12600)  OPO  60 

COMMON /BLOCKE/ NAME (4) ,L1,L2,ISRFLG  OPO  70 

COMMON/HEADER /NOCARD (80) ,ITLE(60,6) , LNCNT , I  PR  I  NT , NPAGE , I  PUNCH  OPO  80 

C0MM0N/SCRAT/NS,NS2,A(13500)  OPO  90 

COMMON /KFMT/KFMT (100)  OPO  100 

C0MM0N/FMAT/IFMTX(6) ,I0SWT,IFMTS(6) ,LHEAD (96)  OPO  110 
COMMON/BLOCKD/IARGS(100) , KIND (100) ,ARGTAB (100 ) (NRMAX ,NROW,NCOL ,      OPO  120 

1NARGS ,VWXYZ (8) ,NERROR  OPO  130 

DIMENSION  ARGS(IOO) , I IRGS  (100 )  OPO  140 

EQUIVALENCE  (ARGS ( 1 ), RC ( 12501 )),( I IRGS ( 1 ) (KFMT ( 1 ) )  OPO  150 

DIMENSION  B(l)  OPO  160 

C         *****  OPO  170 

C         *****  OPO  180 

C         *****  OPO  190 

C         *****  OPO  200 

IF  (L2.EQ.1)  GO  TO  1620  OPO  210 

IF  (MX.GT.l)  GO  TO  1640  OPO  220 

1620    WRITE  (IPRINT,  1625)   (LHEAD ( 1 1 ) , 1 1=13 , 24 ) , (LHEAD ( 1 2 ) , 1 2=1 , 12 ) ,  OPO  230 

1      IARGS(IX) ,IARGS(1)  OPO  240 
1625    FORMAT  ( / /5X , 2 (4X , 12A1 ,4X) , 6X , 9HPREDICTED , 8X , 12HSTD  .  DEV.  0F,25X,  OPO  250 
1  4HSTD . /2X , 3HR0W, 3X ,  9HIN  COLUMN , 1 5 , 6X ,  9HIN  COLUMN , 1 5 , 10X , 6HVALUE0P0  260 

2S,10X,12HPRED.  VALUES , 8X , 9HRESIDUALS , 8X , 4HRES ., 3X , 7HWEIGHTS/ )  OPO  270 

GO  TO  1660  OPO  280 

1640     IF  (MX.GT.2)  GO  TO  1650  OPO  290 

WRITE  (IPRINT, 1645)   (LHEAD ( I ) , 1=1 , 12 ) , I ARGS (NX+4 ) , I ARGS (NX+5 ) ,  OPO  300 

1      IARGS(l)  OPO  310 
1645    FORMAT  ( / /8X , 22HPREDICT0R  VARIABLES  IN , 6X , 12A1 , 8X , 9HPREDICTED , 6X  ,  OPO  320 
1  12HSTD.  DEV.  OF , 22X , 4HSTD . /2X , 3HR0W, 3X , 4HC0L . ,  14  ,6X  ,4HC0L . ,I4,8X,0P0  330 
24HC0L. ,I4,11X,6HVALUES,8X,12HPRED.  VALUES ,6X ,9HRESIDUALS ,7X ,4HRES .OPO  340 

3,3X,7HWEIGHTS/)  OPO  350 

GO  TO  1660  OPO  360 

1650    WRITE  (IPRINT, 1655)   (LHEAD (I ), 1=1 , 12) , IARGS (NX+4) , IARGS (NX+5) ,  OPO  370 

1      IARGS(NX+6) ,IARGS(1)  OPO  380 
1655    FORMAT  ( / /12X  ,  22HPREDICT0R  VARIABLES  IN , 9X , 12A1 , 6X , 9HPREDICTED , 4X  OPO  390 
1,12HSTD.  DEV.  OF , 19X ,4HSTD . /2X , 3HR0W, 2X , 3 (4HC0L . , 14 , 4X) , 2X , 4HC0L . ,0P0  400 

2I4,9X,6HVALUES,6X,12HPRED.  VALUES , 4X , 9HRESI DUALS , 6X , 4HRES ., 3X ,  OPO  410 

37HWEIGHTS / )  OPO  420 

1660     IX  =  IIRGS(IX)  OPO  430 

IY  =  IIRGS(l)  OPO  440 

IND3  =  ND3+1  OPO  450 

IND2  =  ND2+1  OPO  460 

IND4  =  ND19+1  OPO  470 

LL  =  0  OPO  480 

NSD  =  8  OPO  490 

NWM  =  18  OPO  500 

IF  (L2.EQ.1   .OR.  MX.EQ.l)  GO  TO  1666  OPO  510 

1X2  =  IIRGS(NX+5)  OPO  520 

NWM  =  2*(2/MX)  OPO  530 

LL  =  4-NWM  OPO  540 

NSD  =  4+NWM  OPO  550 

NWM  =  NWM+10  OPO  560 

CALL  RFORMT  (RC  ( 1X2 )  ,N  ,NSD  ,NW2  ,^IDEC2  ,NWM,  A  (1 )  ,  A  (1 )  ,0,0)  OPO  570 

IF  (MX.EQ.2)  GO  TO  1666  OPO  580 

1X3  =  IIRGS(NX+6)  OPO  590 
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1667 


1670 
1680 


CALL  RFORMT  (RC ( 1X3 ) , N ,NSD ,NW3 ,NDEC3 ,NWM, A (1 ) , A (1 ) ,0,0)  0P0  600 

1666    CALL  RFORMT   (RC(IX  ) , N , NSO , NW1 , NDEC1 ,  NWM  ,A(1) ,A(1) ,0,0)  OPO  610 

CALL  RFORMT  (RC(IY  ),N,     8 ,NW4 , NDEC4 , 18-LL , A (1 ) , A ( 1 ) , 0 , 0 )  OPO  620 

CALL  RFORMT  (A(IND3),N,     8 , NW5 , NDEC5 , 17-LL , A (1 ) , A ( 1 ) , 0 , 0 )  OPO  630 

CALL  RFORMT   (A(IND2),N,     8 , NW6 , NDEC6 , 17-LL , A ( 1 ) , A ( 1 ) , 0 , 0 )  OPO  640 

CALL  RFORMT   (A(IND4),N,     8 , NW7 , NDEC7 , 17-LL , A ( 1 ) , A ( 1 ) , 0 , 0 )  OPO  650 

IF  (KIND(2) .EQ.l)  GO  TO  1667  OPO  660 

IW  =  I IRGS  (2 )  OPO  670 

CALL  RFORMT  (RC ( I W) , N , 4 , NW9 , NDEC9 , 9 , A ( 1 ) , A ( 1 ) , 0 , 0 )  OPO  680 

GO  TO  1680  OPO  690 

CALL  RFORMT  (ARGS (2 ) ,1,4 ,NW9 ,NDEC9 ,9,A(1) ,A(1) ,0,0)  OPO  700 

CALL  RFORMT   (A ( 1 ) , 1 , 4 , NW9 , NDEC9 , 0 , ARGS (2 ) , B (98 ) , 11-NW9 , 1 )  OPO  710 

WT=ARGS(2)  OPO  715 

FORMAT  (1X,I4,97A1,0PF7.2,11A1)  OPO  720 

DO  1745  1=1, N  OPO  730 

CALL  RFORMT  (A (1 ) , 1 , NSD ,NW1 , NDECl , 0 , RC ( IX  ) , B ( 1 ) , NWM+2-NW1 , 1 )  OPO  740 

IF  (L2.EQ.1  .OR.  MX. EQ.l)  GO  TO  1685  OPO  750 
CALL  RFORMT  (A ( 1 ) , 1 ,NSD ,NW2 , NDEC2 , 0 , RC ( 1X2 ) , B (NWM+3 ) , NWM+2-NW2 , 1 )  OPO  760 

1X2  =  1X2+1  OPO  770 

IF  (MX.EQ.2)  GO  TO  1685  OPO  780 

CALL  RFORMT   (A (1 ) , 1 , NSD , NW3 , NDEC3 , 0 , RC ( 1X3 ) , B (25 ) , 12-NW3 , 1 )  OPO  790 

1X3  =  1X3+1  OPO  800 
1685  CALL  RFORMT  (A (1 ) ,1,8 ,NW4 ,NDEC4 , 0 , RC ( IY ) ,B (4*LL+21 ) , 20-LL-NW4 , 1 )  OPO  810 
CALL  RFORMT  (A (1 ) , 1 , 8 , NW5 ,NDEC5 , 0 , A ( IND3 ) , B (3*LL+41 ) , 19-LL-NW5 , 1 )  OPO  820 
CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW6 ,NDEC6 , 0 , A ( IND2 ) , B (2*LL+60 ) , 19-LL-NW6 , 1 )  OPO  830 
CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW7 ,NDEC7 , 0 , A ( IND4 ) , B (LL  +  79 ) , 19-LL-NW7 , 1 )  OPO  840 

IF  (KIND(2) .EQ.l)  GO  TO  1730  OPO  850 

CALL  RFORMT  (A ( 1 ) , 1 , 4 , NW9 , NDEC9 , 0 , RC ( I W) , B (98 ) , 11-NW9 , 1 )  OPO  860 

WT=RC(IW)  OPO  865 

IW  =  IW+1  OPO  870 

1730    IF(WT.GT.O.O)  STDRES=A (IND4) /FSQRT (SSQ/ WT-A ( IND2 ) **2 )  OPO  875 

IF(WT.LE.O.O)  STDRES=0.0  OPO  880 
WRITE  (IPRINT,1670)  I , (B ( 1 1 ) , 1 1=1 , 97 ) , STDRES , (B ( 1 1  ) , 1 1=98 , 108 )        OPO  890 

1740     IX  =  IX+1  OPO  900 

IY  =  IY+1  OPO  910 

IND3  =  IND3+1  OPO  920 

IND2  =  IND2+1  OPO  930 

1745     IND4  =  IND4+1  OPO  940 

RETURN  OPO  950 

END  OPO  960 
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SUBROUTINE  ORTHO  ORT  10 

C         VERSION    5.00         ORTHO           5/15/70  ORT  20 

DOUBLE  PRECISION  FDSQRT ,DK2 , SUM, Y SUM  ORT  40 

COMMON  /ABCDEF/  L(48)  ORT  50 

COMMON  /BLOCRC/  NRC  , RC  ( 12600 )  ORT  60 
COMMON  /BLOCKD/  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NORT  70 

1ARGS ,VWXYZ(8) ,NERROR  ORT  80 

DIMENSION  ARGS(IOO)  ORT  90 

EQUIVALENCE  ( ARGS ( 1 ), RC  ( 12501 ) )  ORT  100 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG  ORT  110 
COMMON  /HEADER/  NOCARD (80 ) , ITLE  (60  , 6 ) , LNCNT  ,  IPRINT  , NPAGE  ,  IPUNCH      ORT  120 

COMMON  /SCRAT/  NS , NS2 , A  ( 13500 )  ORT  130 

COMMON  /KFMT /  KFMT(IOO)  ORT  140 

COMMON  /FMAT /  IFMTX (6) , IOSWT , IFMTS (6) ,LHEAD (96)  ORT  150 

DIMENSION  IIRGS(IOO)  ORT  160 

EQUIVALENCE  ( I IRGS ( 1 ) , KFMT ( 1 ) ) ,   (B  (1) , IB)  ORT  170 

DIMENSION  IMTRXA(2,3)  ORT  180 

DIMENSION  B(120),  IHC(4),  IHT(8)  ORT  190 

DATA  IHC(l) ,IHC(2) , IHC (3) ,IHC(4)/3H  TE ,3HRM  ,3HC0L ,3HUMN/  ORT  200 

q         ***             *******             *******  ORT  210 

C         ORTHONORMALIZATION  PROGRAM    BY  PHILIP  J.  WALSH    JULY  1,  1967           ORT  220 

C         REVISED    BY  S.  PEAVY    5/28/68  ORT  230 

C         REVISED  BY  DAVID  HOGBEN  AND  SALLY  PEAVY,  SEL,  NBS .  9/23/69.  ORT  240 

C         LEAST  SQUARES  PROGRAM  USING  GRAM  SCHMIDT  PROCESS  ORT  250 

C  ORT  260 

C         POLYFIT    Y  IN  COL  ++  WITH  WEIGHTS  (ALL  EQUAL  TO  **)  ORT  270 

C                                                                   (IN  COL  ++)  ORT  280 

C                   USING  POLYNOMIAL  OF  DEGREE  , ,  TO  X  IN  COL  ++  ORT  290 

C                   STORE:  COEFFICIENTS  IN  COL  ++  ORT  300 

C                               DEVIATIONS  IN  COL  ++  ORT  310 

C                               STANDARD  DEV  OF  PREDICTED  VALUES  IN  COL  ++  ORT  320 

C                               FOURIER  COEFFICIENTS  IN  COL  ++  ORT  330 

C                               VARIANCE  COVARIANCE  MATRIX  STARTING  IN  ( , ,  ++)             ORT  340 

C                   ONLY  FIRST  4  ARGUMENTS  MUST  BE  SPECIFIED.  ORT  350 

C                   STORAGE  WILL  TAKE  PLACE  FOR  ONLY  THE  STORAGE  ARGUMENTS  ORT  360 

C                       PROVIDED  ORT  370 

C                               L2=l  POLYFIT:  L2=2  SPOLYFIT  ORT  380 

C  ORT  390 

C         FIT    Y  IN  COL  ++  WITH  WEIGHTS (ALL  EQUAL  TO  **)  AS  A  ORT  400 

C                                                           (IN  COL  ++)  ORT  410 

C                   FUNCTION  OF  K=++  VARIABLES  IN  COLS  ++,++,++  +++  ORT  420 

C                   STORE:  COEFFICIENTS  IN  COL  ++  ORT  430 

C                               DEVIATIONS  IN  COL  ++  ORT  440 

C                               STANDARD  DEV  OF  PREDICTED  VALUES  IN  COL  ++  ORT  450 

C                               FOURIER  COEFFICIENTS,  ETC.  IN  COL  ++  ORT  460 

C  VARIANCE  COVARIANCE  MATRIX  STARTING  IN  (++  ,,)  ORT  470 
C                   MINIMUM  OF  4  ARGUMENTS  IS  NEEDED  BEFORE  COMMAND  IS  EXEC.        ORT  480 

C                               L2=3  FIT        :  L2=4  SFIT  ORT  490 

C  ORT  500 

C         MORTHO      X  (,,  ++)     R=(,  C=, ,  WITH  WEIGHTS  (  ALL  EQUAL  TO  **)  ORT  510 

C                                                                                  (  IN    COL  ++)  ORT  520 

C                   STORE  IN  M  (,,  ++)     A  MATRIX  IN  ( , ,  ++)  ORT  530 

C                               L2=5  MORTHO:  ORT  540 

C  ORT  550 

C  ORT  560 

IXl(I,J,IN)=IN+(I*(I-l))/2+J  ORT  570 

C         PRECHECKING  SECTION  ORT  580 

IF  (L2.EQ.1.0R.L2.EQ.3)  GO  TO  8  ORT  582 

IF  (L2.EQ.2)   IF  (NARGS-4)  8,6,8  ORT  584 
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IF  (NARGS.NE.IARGS(3)+3)  GO  TO  8 

ORT  586 

6 

CALL  ERROR  (236) 

ORT  588 

RETURN 

ORT  590 

8 

IREFIT=0 

ORT  595 

IF  (NARGS.GT.O)  GO  TO  10 

ORT  600 

CALL  ERROR  (10) 

ORT  610 

RETURN 

ORT  620 

10 

IF  (NRMAX.NE.O)  GO  TO  20 

ORT  630 

CALL  ERROR  (9) 

ORT  640 

RETURN 

ORT  650 

20 

NMUI=1 

ORT  660 

C 

IF  L2  =5    THEN  COMMAND  IS  MORTHO 

ORT. 670 

IF  (L2.EQ.5)  GO  TO  1850 

ORT  680 

IF  (NARGS.LT.4)  GO  TO  1830 

ORT  690 

c 

COMMAND  IS  POLYFIT  OR  FIT 

ORT  700 

CALL  ADRESS  (1 , I IRGS (1 ) ) 

ORT  710 

IF  ( I IRGS (1 )  .LE.O)  CALL  ERROR  (11) 

ORT  720 

IF  (KIND(2) .EQ.l)  GO  TO  30 

ORT  730 

CALL  ADRESS  (2,1 IRGS (2 ) ) 

ORT  740 

IF  (I IRGS (2 )  .LE.O)  CALL  ERROR  (11) 

ORT  750 

GO  TO  40 

ORT  760 

30 

SU=NRMAX 

ORT  770 

WSUM=SU 

ORT  780 

IF  (ARGS (2) .LE .0 .0)  CALL  ERROR  (24) 

ORT  790 

NMUI=2 

ORT  800 

40 

NST=1 

ORT  810 

IF (KIND (3) .EQ.l)  I ARGS (3 )=ARGS (3 ) 

ORT  815 

NEND=NARGS 

ORT  820 

J=NARGS-4 

ORT  825 

IF(L2.GT.2)  J=J-IARGS(3)+1 

ORT  830 

IF (J .LE.4.AND.J  .GE.O)  GO  TO  50 

ORT  835 

IF  (J  .NE.6)  GO  TO  1830 

ORT  837 

45 

NEND=NARGS-2 

ORT  840 

NST=2 

ORT  850 

50 

DO  60  I=4,NEND 

ORT  860 

CALL  ADRESS  (I , I IRGS  ( I ) ) 

ORT  870 

IF  ( I IRGS ( I )  .LE.O)  CALL  ERROR  (11) 

ORT  880 

60 

CONTINUE 

ORT  890 

M=IARGS(3) 

ORT  900 

IF  (L2.LE.2)  M=M+1 

ORT  910 

N=NRMAX 

ORT  920 

FN=N 

ORT  930 

GO  TO  (100,70)  ,  NST 

ORT  940 

70 

CALL  ADRESS  (NARGS , 1ST) 

ORT  950 

IF  (IST.GT.O)  GO  TO  80 

ORT  960 

CALL  ERROR  (11) 

ORT  970 

RETURN 

ORT  980 

80 

MMTXR=M 

ORT  990 

MMTXC=M 

ORT1000 

IST=IST-1+IARGS (NARGS-1 ) 

0RT1010 

IF  (IARGS(NARGS)+M-1.GT.NC0L)  MMTXC=NCOL- 

•  IARGS(NARGS)+1 

0RT1020 

IF  (IARGS(NARGS-1)+M-1.GT.NR0W)  MMTXR=NROW-I ARGS (NARGS-1 )+l 

0RT1030 

IF  (MMTXR.GT.O)  GO  TO  90 

0RT1040 

NARGS=NARGS-2 

0RT1050 

CALL  ERROR  (213) 

0RT1060 

GO  TO  100 

0RT1070 

90 

IF  (MMTXR  .  NE  .  M.-OR  .  MMTXC  .  NE  .  M)  CALL  ERROR 

(213) 

0RT1080 

100 

GO  TO  (110,140),  NMUI 

0RT1090 

110 

SU=0 .0 

0RT1100 

! 
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WSUM=0.0 
L22=I IRGS (2 ) 
L22A=L22 
DO  130  1=1 ,N 

IF  (RC(L22A))  1840,130,120 
SU=SU+1.0 

WSUM=WSUM+RC(L22A) 

L22A=L22A+1 

FM=M 

IF   (SU-FM)  150,160,170 

CALL  F.RROR  (24) 

RETURN 

DENOM=1.0 

GO  TO  180 

DENOM=FSQRT (SU-FM) 

NPM=N+M 

M1=M-1 

M2=M+1 

N1=N-1 

N2=N+1 

MD1=(M* (M2) ) /2 


ND1=M2*NPM 

X  REQUIRES  ND1  CELLS 

GET  A        (ND1  +1)  FOR  START  OF  PK 

ND2=M*NPM 

MD3=N02+N 

ND3=ND1 

ADD  NPM  TO  REACH  XP 

ND4=ND3+NPM 

ADD  NPM  TO  REACH  QK 

ND5=ND4+NPM 

ADD  (M+l)  TO  REACH  CV 

ND6=ND5+M2 

ADD  (M*(M+l))/2  +  M    TO  REACH  VCV 

ND66=MD1+M 

ND7=ND6+ND66 

ADD  THE  SAME  AMOUNT  TO  REACH  Q 
ND8=ND7+ND66 

Q  IS  (M+l)  CELLS  LONG  THEN  COMES  Q2 
ND9=ND8+M2 

Q2  E  AND  EP  ARE  EACH  M  CELLS  LONG 

ND10=ND9+M 

ND11=ND10+M 

ND12=ND11+M 

THE  A  MATRIX  IS  NEXT 

ND13=ND12+MD1 

GRAM  FACTOR  STORAGE 

ND14=ND13+M2 

ENF 

CV  DIAGONALS 

ND16=ND14+M 

VCV  DIAGONALS 

ND17=ND16+M 

ND18=ND17+M 

ND19=ND18+NPM 

ND20=ND19+N 

IF  (IREFIT.EQ.l)  GO  TO  190 


ORT1110 
0RT1120 
ORT1130 
0RT1140 
0RT1150 
ORT1160 
0RT1170 
0RT1180 
0RT1190 
0RT1200 
0RT1210 
0RT1220 
0RT1230 
0RT1240 
0RT1250 
0RT1260 
0RT1270 
0RT1280 
0RT1290 
0RT1300 
0RT1310 
0RT1320 
0RT1330 
0RT1340 
0RT1350 
0RT1360 
0RT1370 
0RT1380 
0RT1390 
ORT1400 
0RT1410 
0RT1420 
0RT1430 
0RT1440 
0RT1450 
0RT1460 
ORT1470 
0RT1480 
0RT1490 
0RT1500 
0RT1510 
0RT1520 
0RT1530 
ORT1540 
0RT1550 
0RT1560 
0RT1570 
0RT1580 
0RT1590 
ORT1600 
0RT1610 
0RT1620 
0RT1630 
0RT1640 
0RT1650 
0RT1660 
0RT1670 
0RT1680 
0RT1690 
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x  i—     >  ai  a  a  a    ax    nr  \     a  a  i  i      rnnAn     /  a  *>  \ 

IF  (ND20.GT.NS)  CALL  ERROR  (23) 

0RT1700 

IF  (NERROR . NE . 0 )  RETURN 

0RT1710 

190 

ti  n  n  An  i 

NRBAR=1 

Ai  A  ^T"  "I   T  f\  f\ 

0RT1720 

1=1 IRGS (1 ) 

0RT1730 

L22A=L22 

0RT1732 

Artllf  1       OA   /  I    O  A  \ 

C0NS3=RC (L22) 

Ai  A  T"  1        o  o 

0RT1733 

I F  (KIND (2 ) . EQ . 1 )  C0NS3=ARGS (2 ) 

0RT1735 

A  A  AI  t"  1       A  A  /  T  \ 

C0NS1=RC ( I ) 

0RT1736 

AAlirn        A  A    /   T  \ 

C0NS2=RC ( I ) 

0RT1737 

a  a        iac        Ti     i     hintiA  v 

DO     195  I1=1,NRMAX 

A  A  T  1  *T  a 

0RT1738 

T  T  /  1/  T  lin  /  1  \      t~  A      r\  \      A  A  AI  A  *i      A  A  /  l    a  a  A  \ 

IF (KIND (2 ) . EQ . 0 )  C0NS3=RC (L22A) 

0RT1740 

IF(C0NS3)  192,192,191 

0RT1741 

191 

A  A  AI  f*      A  A  /  T  \ 

C0NS=RC ( I ) 

0RT1742 

T  T  /  Artiif     IT     A  A  AI  a  i  v      Art  ti  r  i      a  Akir 

IF  (CONS .LT .C0NS1)  C0NS1=C0NS 

0RT1743 

T  r-    /  A  AllA        AX        A  A  II  f  A   \         AAIIA  «        A  Allf 

IF  (CONS .61  .C0NS2)  C0NS2=C0NS 

0RT1745 

192 

T       T  1 

1  =  1+1 

0RT1746 

T  A  C 

195 

1    A  A  A       1    A  A  A  1 

L22A=L22A+1 

0RT1747 

YC0NS= (C0NS2+C0NS1 ) /2 .0 

0RT1748 

A  A       X  A         /  A  A  /"»        AAA        A   i  A        A    1  fi        n    i  A   I               1  A 

GO  TO  (200,200,240,240,240),  L2 

0RT1750 

L 

TUTC     TC     nAI  uriT 

1  H 1 S   IS  POLYF  I  ( 

A  A  X  1  *^  /  a 

0RT1760 

AAA 

200 

L33=I IRGS (4 ) 

0RT1770 

ft  aw  a  n  A  A  r 

MXARGS=5 

0RT1780 

1    O  O  A  lOO 

L33A=L33 

0RT1790 

K=NPM+1 

0RT1800 

f\A      ATA       T       i  AI 

UU  210   1=1 , N 

A  A  X  1  A  1  A 

ORT1810 

A  /  T  \      1  A 

A ( I )=1 . 0 

A  A  X  ^  AAA 

ORT1820 

A    /  1/  \       r>  A  /  I  OOA\ 

A (K)=RC (L33A) 

0RT1830 

1/      1/  1 

K=K+1 

0RT1840 

A  1  A 

210 

IOOA       lOOA  1 

L33A=L33A+1 

0RT1850 

TC       /  Ai     C  A      A  \       A  A      TA  AAA 

IF    (M.EQ.2)  GO  TO  320 

A\  A         ^    A   £  A 

0RT1860 

f\  A       AOA      L/       A  111 

DO  230  K=2,M1 

0RT1870 

IOOA  IOO 

L33A=L33 

0RT1880 

K2=K*NPM+1 

0RT1890 

1/1       1/  A  IIDtl 

K1=K2-NPM 

0RT1900 

UU    220    1=1 , N 

A  A  X  1  A  1  A 

ORT1910 

A    /  1/  A  \       A              \  *  A  A    •  1  OOA\ 

A(K2)=A(K1).RC(L33A) 

Ai  f"^         ^    A  A  A 

ORT1920 

1/  A       1/  A  1 

K2=K2+1 

0RT1930 

K1=K1+1 

ORT1940 

220 

1      **    rl    ft          1      "6           ft  1 

L33A=L33A+1 

0RT1950 

A  "5  A 

230 

AAiiT  T  All  IC 

CONTINUE 

A  A  T  "1   A  #  A 

0RT1960 

A  A      X  A 

GO  TO  320 

0RT1970 

240 

T  A 

1=4 

A  fi^k         *    A  A  A 

0RT1980 

A 

C 

r  Tlln     A 1  |  T      t  r*      All       V  /  T  \               1      A          TC      If  A 

FIND  OUT  IF  ALL  X(I)  =  1.0,   IF  50 

C  t~  T      AIV       1       ■tin      AAV      R  A  i 

SET  NX=1  AND  MX=M-1 . 

A  A  X  1  AAA 

0RT1990 

1    A  A        T  T  A  A  A    /  ^  \ 

L33=I IRGS (4) 

A  A  X*  A  A  A  A 

0RT2000 

ftl  V/  i 

NX=1 

A  A  X  A  A  1  a 

0RT2010 

|-\  A      AAA      AI  111/       1  Al 

DO  250  NW6=1,N 

A  A  X  A  A  A  A 

ORT2020 

T  ^       /AAC/HA/IOA\       1       A\       If"      1       r*      /    \       A  A 

IF  (ABS (RC (L33)-l .0) .LE . 1 .E-6)  GO 

TO  250 

A  dO  T  A  A  A  A 

0RT2030 

NX=0 

A  A         A  A    a  A 

0RT2040 

A                   A  ASA 

GO  TO  260 

0RT2050 

OCA 

250 

loo      IOO  1 

L33=L33-t-l 

A  n  X  OA/  A 

ORT2060 

"1  /  A 

260 

KfV      IJA  V  A  /  1      11     AIV  \ 

MX=MAX0 ( 1 , M-NX ) 

ART A AOA 

ORT2070 

IF(NX.EQ.0.0R.L2.EQ.5)  YC0NS=0.0 

A\            A  A  A 

0RT2075 

||w  A  nAA        ftl  4 

MXARGS=M+4 

ORT2080 

1     MM       ft  SW  ft  A  A  A  t 

L44=MXARGS-1 

A  F\         A  A  A  A 

ORT2090 

J=l 

0RT2100 

ATA 

270 

A  A       A  1  A       T  1         T       1  MM 

DO  310  11=1 ,L44 

A  O  T  A  1  r  A 

0RT2150 

l/i  1 

K1=J 

A  A  X  A  1  /  A 

0RT2160 

L33=I I RGS (11) 

0RT2170 

K2=K1 

0RT2180 
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nn  inn  T 9— l  m 

P  D  T  9  1  OA 

UK  1 Z 1 90 

ZVO 

A  (If 9 \ —  DC  1 1  1 1  \ 

P  D  T  9  9  9  A 
UK  1  HIV 

If  9— If  9  j.1 
l\  £=l\  £  +  1 

(IDT  9  9  1  A 

UK  1 L 1 3  U 

300 

111    | ,1 
L3  3=L3  3  +  1 

fl  DT  9  9  A  ft 

UK  1 Z  Z40 

T  1  If  1  M_9 

fl  D  T  9  9  C  A 
UK  1  ZZD0 

3  10 

J  =J  +iMr  wi 

P  D  T  O  O  i  A 

UK  1 ZZ60 

p 

rFMERATF    TnFMTTTV    MATPTY    A 1 ITMF MT A T T fiM 
UtNtKA  1  t    lUC.ni  11  I    MA  1  rv  1  A    AUbMtli  1  A  1  1UIV 
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1iMU7=1NU7  +  1 

PDT A  O  A  A 

UK  1 bl 00 

1320 

TCTADT     TCTADT.  T  P AMD 

I b I AK 1 =lb 1 AK 1 +1LUNB 

ADT A  O 1  A 

UK  1  OA  10 

C 

CTADC    PDAM    CAPTADC       WCPTPD    MPDMC  AMR 

bTUKb  bKAM  rALIUKb,    VtLlUK  NUKMb  AIMU 

PDAM 

bKAM 

T1CTCDMTMAMTC 
Ub  1  bKMl  IMAN  1  b 

PDT A  0  0  A 
UK  1  OA AO 

1330 

IIC  TAD     MDA1AI    1      TADPC  /  MADPC     1\  M 

MbTUr=NKUW-l-lAKbb (IMAKbb-1 )-M 

PDTAO in 
UK  1 6 A30 

IP  /  lie  TAD    IT     /     1\\     PA    TA     1  IDA 

1 r (Mb lUr.LI.(-l))   bU    1 U  13BU 

ADTA04P 
UK  1 0A4U 

Tuni  i   iini  i  .  i 
1NU13=NU13+1 

ADTA9  cn 
UK  1 OA3U 

I ND 14=ND 14+1 

ADT  A  O  A  A 

UK  16260 

GMD 1 =1 . 0 

ADT A  O  7  A 
UK  1  6 A  / 0 

TCTD      TCT  II 

IbTK=I5T+M 

ADT A  O  O  A 

UK  1 6 aBO 

nft      llTft      T      1  IIIITVP 

DO  1370  1=1,MMIaL 

PDT A 1  on 
UK  1 6 A7U 

TC     /MCTADl     l  lift    11CA    1  1A(I 

lr    (MblUr)    1360, 1330, 134U 

UK  1 0 JUU 

1340 

THAT     P  II A  T  *  /  A  /  T  II  H  1  1  \   /  A  /  TAIIll  X  1  1  4*1 

bMD I =bMU I    ( A ( l NU13 ) / A ( 1NU14 ) )  L 

UK  1 OJ1U 

DP/TCTPlOI _PMnT 
Kl»  ( 1  b  1  ?\+ L  )  =oMU  1 

UU  1  w  J  A  w 

1350 

RC(ISTR)=A(IND13) 

0RT6330 
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IN013=IND13+1 

0RT6340 

1360 

RC(ISTR+1)=A(IND14) 

0RT6350 

IND14=IND14+1 

0RT6360 

1370 

ISTR=ISTR+NR0W 

0RT6370 

C 

STORE  FOURIER  COEFFICIENTS 

0RT6380 

1380 

IF  (LSWT.EQ.l)  RETURN 

0RT6390 

1390 

LST=IIRGS(MXARGS+3) 

0RT6400 

IN09=ND9 

0RT6410 

DO  1400  1=1, M 

0RT6420 

IND9=IND9+1 

0RT6430 

RC (LST)=A(IND9) 

0RT6440 

1400 

LST=LST+1 

0RT6450 

IF   (NR0W-(M+1))  1440,1420,1410 

0RT6460 

1410 

RC (LST+1)=YSUM 

0RT6470 

1420 

RC  (LST)  =  (SU-FM)*SSQ 

0RT6480 

LST=LST+2 

0RT6490 

IF  (M+2 .GE .NROW)  GO  TO  1440 

ORT6500 

■    A  T'  a        ft    f~  -y       ■  ■  m 

LSTA=LST+M-1 

0RT6510 

IF  (2*M+2 .GT .NROW)  LSTA=I IRGS (MXARGS+3 ) +NR0W-1 

0RT6520 

IND8=ND8 

0RT6530 

DO  1430  I=LST,LSTA 

0RT6540 

IND8=IND8+1 

0RT6550 

1430 

RC(I)=A(IND8) 

0RT6560 

C 

STORE    S.D.  OF  PREDICTED  VALUES 

0RT6570 

1440 

■    A  t  An       t  t  n  a  a    ,  a  M\e  a  n  A  A  , 

LST0R=IIRGS (MXARGS+2) 

0RT6580 

IPIC=1 

0RT6590 

IND2=ND2+1 

0RT6600 

DO  1450  1=1, N 

0RT6610 

RC(LST0R)=A(IND2) 

ORT6620 

IND2=IND2+1 

0RT6630 

1450 

LST0R=LST0R+1 

0RT6640 

C 

START  PRINTING 

0RT6650 

1460 

GO  TO  (1480,1470,1480,1470,1470),  L2 

0RT6660 

1470 

n          i  i  a  1 1 

RETURN 

ORT6670 

1480 

ITITLE=1 

0RT6680 

IF  (L2.EQ.3)  ITITLE=2 

0RT6690 

IPG=1 

0RT6700 

NSU=SU+.5E-5 

0RT6710 

CALL  PREPAK  (5 ,NW1 , NW1 , I ARGS ( 1 ) , LHEAD ) 

0RT6720 

IF  (NW1.EQ.0)  GO  TO  1500 

0RT6730 

DO  1490  1=1,4 

0RT6740 

LHEAD(I)=L(45) 

0RT6750 

1490 

LHEAD(I+8)=L(45) 

0RT6760 

LHEAD(5)=L(14) 

ORT6770 

LHEAD(6)=L(11) 

0RT6780 

LHEAD(7)=L(30) 

ORT6790 

LHEAD(8)=L(11) 

ORT6800 

1500 

CALL  PREPAK  (5 ,NW1 ,NW1 , I ARGS (4) , LHEAD (13) ) 

0RT6810 

IF  (NW1.EQ.0)  GO  TO  1510 

0RT6820 

LHEAD(13)=L(45) 

0RT6830 

LHEAD(14)=L(32) 

A  A  T  /  ft  i  a 

0RT6840 

LHEAD(15)=L(11) 

0RT6850 

LHEAD (16)=L (28) 

0RT6860 

LHEAD(17)=L(19) 

0RT6870 

LHEAD(18)=L(11) 

0RT6880 

LHEAD (19)=L (12 ) 

A  A  T*  y  AAA 

0RT6890 

LHEAD(20)=L(22) 

0RT6900 

LHEAD (21)=L (15) 

0RT6910 

LHEAD(22)=L(45) 

0RT6920 
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LHEAD (23 )=L  (34 ) 

LHEA0(24)=L(45) 
1510    CALL  PAGE  (4) 

WRITE  (IPRINT,1990)   (LHEAD ( I ), 1=1 , 12 ), IARGS ( 1 ) 

GO  TO  (1520 ,1820) ,  ITITLE 
C         PRINT  POLYFIT  TITLE 

1520     WRITE  (IPRINT,2000)   IARGS (3 ), (LHEAD ( I ), 1=13 ,24) , IARGS (4) 
1530    GO  TO  (1540,1550)  ,  NMUI 
1540  NZW=NRMAX-NSU 

WRITE  (IPRINT,2010)  NSU ,NZW, IARGS (2 ) 

GO  TO  1560 

1550    CALL  RFORMT  (ARGS (2 ) ,1,8 ,NW1 ,NDEC1,10,A(1) ,A(1) ,0,0) 

CALL  RFORMT  (A(l) ,  1 , 8  ,NW1 , NDECl , 0 , ARGS (2) ,B(1) ,0,0) 

WRITE  (IPRINT,2020)  NSU , (B ( I ) , 1=1 , 10 ) 
1560    GO  TO   (1570,1580,1610,1650),  IPG 
1570  IXA=4 

IF   (L2.EQ.3)  IXA=IXA+(M-MX) 

IX=IXA 

CALL  OPONE  (N,M,MX,NX,ND2,ND3,ND19,B,SSQ,IX) 
IPG=2 

1580     IF   (NSU.GE.3)  GO  TO  1590 
WRITE  (IPRINT,2030) 
GO  TO  1600 

1590    CALL  ORTPLT  (ND19 , ND2 , N , SSQ , ND3 , IB , I IRGS ( IXA) , I IRGS (2 ) ) 
1600  IPG=3 

GO  TO  1510 
1610    CALL  OCOVAR  (M, ND7 , MDl , IHC , B , IHT ) 
C         PRINT  ANALYSIS  OF  VARIANCE 

CALL  OANOVA  ( YSUM, SU , ND9 , FM, M, N , ND7 , SSQ , IHC , NSU , B) 

GO  TO  1660 
C         REFIT  FOR  M=M-1 
1620  IREFIT=1 

M=M-1 

FM=M 

M1=M-1 

M2=M+1 

SSOLD=SS 

IND17=ND17+1 

IND18S=ND18+N 

IND19=ND19+1 

IND19S=ND19 

DO  1630  J=1,M2 

A(IND19)=A(IND17) 

IND19=IND19+1 
1630  IND17=IND17+1 

IF(M.EQ.O)  GO  TO  1640 

GO  TO  170 

C         BEGIN  REFIT  TO  PREDICTED  VALUES 
1640  M1=M 

C         REFIT  FOR  M=M-1  COMPLETE-OUTPUT  PAGE  3 
IPG=4 
M  =  M  +  1 
GO  TO  1510 

1650    CALL  OCOEFF  (Ml ,N ,ND18 ,ND17 , IND19S , IND18S , IHC ,B , IND7S ,NSU ,SS 
1,YSUM) 

RETURN 
1660    IW=I IRGS (2 ) 

IND2=ND2+1 

IND3=ND3+1 


0RT6930 
0RT6940 
0RT6950 
0RT6960 
0RT6970 
0RT6980 
0RT6990 
0RT7000 
ORT7010 
0RT7020 
0RT7030 
0RT7040 
ORT7050 
0RT7060 
0RT7070 
0RT7080 
0RT7090 
0RT7100 
0RT7110 
0RT7120 
0RT7130 
0RT7140 
0RT7150 
0RT7160 
0RT7170 
0RT7180 
0RT7190 
0RT7200 
0RT7210 
0RT7220 
0RT7240 
0RT7250 
ORT7260 
0RT7280 
0RT7290 
0RT7300 
0RT7310 
0RT7320 
0RT7330 
0RT7340 
0RT7350 
0RT7360 
0RT7370 
0RT7380 
0RT7390 
0RT7395 
0RT7400 
0RT7410 
0RT7430 
0RT7440 
0RT7450 
0RT7455 
0RT7460 
,SS0LD0RT7470 
0RT7480 
0RT7490 
0RT7500 
0RT7510 
0RT7520 
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IDPG=2*M+13 

0RT7530 

IFI=1 

0RT7540 

DO  1700  1=1, N 

0RT7550 

GO  TO  (1670,1680) ,  NMUI 

0RT7560 

1670 

A(IND2)=A(IND3)*RC(IW) 

0RT7570 

I W=IW+1 

0RT7580 

GO  TO  1690 

0RT7590 

1680 

A(IND2)=A(IND3)*ARGS(2) 

0RT7600 

1690 

IND3=IND3+1 

0RT7610 

1700 

IND2=IND2+1 

0RT7620 

IND5=ND5+1 

0RT7630 

DO  1720  J=1,M 

0RT7640 

IF=IFI 

0RT7650 

ASUM=0 .0 

0RT7660 

IND2=ND2+1 

0RT7670 

DO  1710  1=1, N 

ORT7680 

ASUM=A(IF)*A(IND2)+ASUM 

0RT7690 

IND2=IND2+1 

0RT7700 

1710 

IF=IF+1 

0RT7710 

A(IND5)=ASUM 

0RT7720 

IFI=IFI+NPM 

0RT7730 

1720 

IND5=IND5+1 

0RT7740 

ADEV=0.0 

0RT7750 

IW=I IRGS (2 ) 

0RT7760 

I F  1=1 

0RT7770 

IND2=ND3+1 

0RT7780 

DO  1770  I=1,N 

0RT7790 

IND5=ND5+1 

0RT7800 

IF=IFI 

0RT7810 

ASUM=0.0 

0RT7820 

DO  1730  J=1,M 

0RT7830 

ASUM=ASUM+A(IF)*A(IND5) 

0RT7840 

IF=IF+NPM 

0RT7850 

1730 

IND5=IND5+1 

ORT7860 

DEV=A(IND2)-ASUM 

0RT7870 

GO  TO  (1740,1750) ,  NMUI 

0RT7880 

1740 

DEV=DEV**2*RC(IW) 

ORT7890 

IW=IW+1 

0RT7900 

GO  TO  1760 

0RT7910 

1750 

DEV=DEV**2*ARGS(2) 

0RT7920 

1760 

ADEV=ADEV+DEV 

0RT7930 

IND2=IND2+1 

0RT7940 

1770 

IFI=IFI+1 

ORT7950 

IND18=ND18+1+N 

0RT7960 

IM=ND12 

ORT7970 

IND7S=ND18+N-M 

0RT7980 

IND7=IND7S+1 

0RT7990 

DO  1810  I=1,M 

0RT8000 

IM=IM+I 

0RT8010 

COEF=0.0 

ORT8020 

IS=IM 

0RT8030 

IND5=ND5+I 

0RT8040 

DO  1780  J=I,M 

0RT8050 

C0EF=C0EF+A(IS)*A(IND5) 

0RT8060 

IS=IS+J 

0RT8070 

1780 

IND5=IND5+1 

0RT8080 

DIF=A(IND18)-C0EF 

0RT8090 

IF  (ABS(DIF) .GT.O.O)  GO  TO  1790 

0RT8100 

C 

8.0  EQUAL  NUMBER  OF  DIGITS  IN  COMPUTER 

0RT8110 
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DIG=8 . 0  0RT8120 

GO  TO  1800  ORT8130 

1790    DIG=-FL0G10(ABS(DIF))+FL0G10(ABS(C0EF))  0RT8140 

DIG=AMIN1(8.0,DIG)  0RT8150 

DIG=AMAX1 (-8 . 0 ,DIG)  0RT8160 

1800    A(IND7)=DIG  ORT8170 

IND7=IND7+1  0RT8180 

1810     IND18=IND18+1  0RT8190 

C         DELETE  GRAM  FACTORS,  VECTOR  NORMS,  GRAM  DETERMINANT  ORT8200 

GO  TO  1620  0RT8210 

C         TITLE  FOR  PRINT  0RT8220 

1820     I I=IARGS (3 ) +3  ORT8230 

IBA=II  0RT8233 

IBC=L(44)  0RT8235 

I F ( 1 1 .GT. 11)11=11  0RT8237 

IF(M.GT.l)  GO  TO  1823  ORT8240 

WRITE  (IPRINT  ,2050)  M,IARGS(4)  0RT8241 

GO  TO  1530  0RT8242 

1823  IF (IBA.EQ. II )  IBC=L(45)  0RT8243 

WRITE  (IPRINT, 2050)  M, I ARGS (4 ) , (L (44 ) , I ARGS ( I ) , 1=5 , 1 1 ) , IBC  0RT8244 

DO     1827     J=l,4  0RT8245 

IF(M.LE.24*(J-l)+8)  GO  TO  1530  0RT8246 

1 1=24* J+ll  0RT8247 

III  =  11-23  0RT8248 

I I=MINO (II, IARGS (3 ) +3 )  0RT8249 

IF(II.NE.III)  GO  TO  1825  0RT8250 

WRITE  (IPRINT, 2060)  IARGS  (II)  0RT8252 

GO  TO  1530  0RT8254 

1825     111=111+1  0RT8256 

IF(II.EQ.IBA)  IBC=L(45)  0RT8257 
1827  WRITE  (IPRINT, 2060)  IARGS ( 1 1 1-1 ) , (L (44 ) , IARGS ( I ) , 1  =  1 1 1 , 1 1 ) , IBC  0RT8258 

GO  TO  1530  0RT8260 

1830    CALL  ERROR  (10)  0RT8270 

RETURN  0RT8280 

1840    CALL  ERROR  (25)  0RT8290 

RETURN  ORT8300 

C         MORTHO  CHECK  0RT8310 

1850     IF  (NARGS .EQ . 7 .OR .NARGS . EQ . 9 )  GO  TO  1860  0RT8320 

CALL  ERROR  (10)  0RT8330 

RETURN  0RT8340 

1860    IF  (IARGS(3) . GE . I ARGS (4 ) )  GO  TO  1870  0RT8350 

CALL  ERROR  (26)  0RT8360 

RETURN  0RT8370 

1870    CALL  ADRESS  (2,IXM)  0RT8380 

IF  (IXM.LE.O)  CALL  ERROR  (11)  0RT8390 

IF  (IARGS(1)+IARGS(3)-1 .GT.NROW)  CALL  ERROR  (17)  0RT8400 

IF  (IARGS(2)+IARGS(4)-1.GT.NC0L)  CALL  ERROR  (17)  0RT8410 

IXM=IXM-1+IARGS(1)  0RT8420 

IF  (NERROR.GT.O)  RETURN  0RT8430 

J=7  0RT8440 

JJ=1  0RT8450 

1880    CALL  ADRESS  (J , IMTRXA ( J J , 1 ) )  0RT8460 

IF  (IMTRXA(JJ ,1) .GT.O)  GO  TO  1900  ORT8470 

1890    CALL  ERROR  (11)  0RT8480 

RETURN  0RT8490 

1900     IMTRXA(JJ,2)=IARGS(3)  0RT8500 

IF  (JJ.EQ.2)  IMTRXA(JJ,2)=IARGS(4)  ORT8510 

IMTRXA(JJ,3)=IARGS(4)  0RT8520 

IF  (IARGS(J-l) .GT.NROW)  GO  TO  1890  0RT8530 
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TMTRXAMI   \\  —  TMTRXAMI   1  ^    1-i.TARGSM   ~\  \ 

\J  r\  1  O  J  "  w 

IF   (IARGS(J)+IARGS(4)-1  GT  NCOL)   IMTRXAfJJ  3 ) =NC0L-I ARGS (J 1 +1 

1  r       y  X  n  IN  V.  J  \  v  yXXniNVJJ  V  ~  }  ~  X  .  VJ  1    .  iluUL  ^       X  1*1  1  IV  A  n  \  \J  *J   t  *t  )  —  11         L      X  niwj  J  \  u  y  x  x 

V  IN  1  O  J  J  \J 

IF   n  ARGS  (  J-l  )  +1  ARGS  ( 3  ) -1  GT  NROW)   IMTRXAUJ  2  )=NR0W-I  ARGS  (J- 

11       ^  1  ni\u  J  y  w     x  }  i  i  n  i\  u  J  y  .j  }  ~  x  .  Vj  l   .  ii  i\  v  n  /      x  in  i  i\  ah  \  w  w  /  *-  y  — 1«  i  \  v  u     iniwij  y  \j 

1)+1  ORTft'iftO 

X^xX      \J  i\  1  U  JU  u 

IF   (JJ  E0  2  OR  NARGS  EO  7}  GO  TO  1910 

XI          ^  "J  O    .  l_  Vj(  .  4-   .  Ul\  .  IIHI\\J  J  .  !_       .  1    f       Uv       IV      X  7  X  V 

0RT8570 

V  IV  1  V  J  1  \J 

1-9 

U  —  7 

v  rv  i  o  j  o  \J 

1    I  —  ? 

ORTft  ^9n 

U  iv  1  Oj/U 

GO  TO  1880 

V  l\  1  uuuu 

1910 

IF   (NERR0R  NE  0)  RETURN 

0RT86 10 

V  IV  1  UU  A  V 

IF   (IMTRXAd  2)  NE  I  ARGS  ( 3  ^  OR  IMTRXAd  3)  NE  IARGS(4H  CALL 

ERR0R0RT8620 

1   ( 213 ) 

0RT8630 

W  l\  1  U  U  V 

IF   (NARGS  EO  7)  GO  TO  1920 

V  l\  1  O  V  "  V 

IF   (IMTRXA(2  2\  NE  IARGS(4)  OR  IMTRXA(2  3)  NE  IARGS(4M  CALL 

ERR0R0RT8650 

U.  IV  IV  V  IV  V  IV  1  o  U  J  \j 

1   f  2 13  ^ 

0RT8ftf>0 

V  IV  1  U  U  U  V 

1920 

IF   (KIND(5)   EO  1)  GO  TO  1930 

0RT8670 

v  iv  i  \J  \J  i  \j 

CALL  ADRESS  (5  IIRGS(2H 

0RT8680 

V  IV  1  V  V  V  \J 

I IRGS ( 1 }-I IRGS (2) 

X  1  1*  U  J  \  X  f  —  X  1  l\  VJ  J  \  L  / 

v  rv  i  o  u  7  v 

IF   (IIRGS(2)  GT  0)  GO  TO  1940 

XI         ^11  l\VJ  J  \  k  /    .  U  1    ■  v  /       UV       IV      X  7  ~  v 

0RT8700 

V  IV  1  O  /  V  v 

CALL  ERROR  (11) 

V  **  L_  l_        LIIIWM         y  X  X  / 

0RT8710 

VIV  1  V*  Xv 

RETURN 

0RT8720 

1930 

SU=IARGS (3 ) 

j  v ~" ™  x  nil  vi -«j  \  y 

0RT8730 

IF   f  ARGS  f  5 1   LE  0  0)  CALL  ERROR  (25) 

0RT8740 

NMUI=2 

0RT8750 

VI*  1  V*  J  \J 

KIND (2 )=i 

i\  i  nu  V     /  — 

0RT8760 

Vl\  1  V  /  vv 

ARGS (2)=ARGS (5) 

0RT8770 

Vr  1  \   1    w  #     f  w 

1940 

M=I ARGS (4) 

0RT8780 

DO  1950  1=1  M 

0RT8790 

VIXIU  /    /  V 

1950 

I IRGS ( 1+3 )-IXM+(  1-1 ) *NR0W 

X  1  li\J  J  y  XT^  ^  —  X  f\  HIT  I  X       X  /       lll\  V  11 

0RT8800 

N-IARGS (3) 

ii— i  nii\3  J  ^  j  j 

0RT8810 

V  IX  1  V  V  X  V 

FN=N 

0RT8820 

V  IN  1  V  V  X>  V 

GO  TO  100 

VJ  \J       IV      X  V  V 

0RT8830 

VIV  1  SJ  \J  *S  \J 

c 

START  STORING  RESULTS  FOR  M0RTH0 

J  1  Hn  1       J  1  Vl\  1  llu      l\L  JUL  1           1    VIA      HIV  l\  1  1  1 V 

0RT8840 

V  IV  1  U  U  i  u 

1960 

IST-IMTRXAfl  1) 

x  j  I  —  x  ill  i  i\An  \  i  f  x  j 

0RT8850 

V  IX  1  UU  J  u 

K=l 

0RT8860 

VIV  1  V  V  V  V 

MMTXC=IMTRXA ( 1  3) 

■■■III  1   /  A  \J        XIVII   1  \  /  \  r»   \   X.    f  ^  f 

0RT8870 

VIX  1  VVf  V 

MMTXR=IMTRXA(1  2) 

1  Villi  1   /  \  1  \         X  III  1   1  \  f\         \   A    m    1^  } 

0RT8880 

wl\  1  VVVw 

DO  1980  1=1  MMTXC 

V  V      X  7  V  V       X  ~ ~  X  f  lillVI  1  r\  V 

0RT8890 

V  IN  1  V  V  7  V 

KK-K 

l\  IX  — 1\ 

0RT8900 

V  IN  1  V  7  V  w 

ISTRR-IST 

X  J   1   l\l\^X  -J  6 

0RT8910 

VIV  1  V  7  X  V 

DO  1970  J=l  MMTXR 

V  V       1  /  1   v       w  X   y  llllll  1  /\  l\ 

ORT8920 

VIN  1  V  /  a-  VJ 

RC  ( I STRR  )=A  i'KK  ) 

i\v  \  x  <j  i  i\i\  f  ^~  n  y  »\i\  y 

0RT8930 

VIN  1  V  /  «/  V/ 

KK=KK+1 

0RT8940 

VIN  1  V  7~W 

1970 

X  7  /  V 

ISTRR-ISTRR+l 

X  J  1  1  \  1  \  —  X  J  1  l\  1  \  T  X 

0RT8950 

V  IN  1  V  7  J  V 

K-K+NPM 

l\  — 1\ T HI  III 

0RT8960 

VIN  1  V  7  V  V 

1980 

IST=IST+NROW 

X  J  1  ™~  X  J  1  Tlll'U  " 

0RT8970 

VINIV7>V 

IF  (NARGS  E0  7)  RETURN 

0RT8980 

VIN  1  V  /  v  W 

LSWT=1 

L  J  n  i  —  x 

0RT8990 

VIN  1  V  7  7  V 

IND7-ND12+1 

1  lit/  /  - - li  v  X  b  x  x 

0RT9000 

V  IN  1    7  V  w  V 

IST-IMTRXA(2  1) 

x  j  I  —  x  iti  I  i\  An  yx.  ,  x  f 

0RT9010 

V  IN  1    7  v  X  V 

MMTXR-IMTRXA ( 2  2) 

llllll  1  A  l\—  X  III  1  i\  An  ^  4  t  f 

0RT9020 

V  IN  1    7  V  tm  V 

MMTXC=IMTRXA (2  3) 

llllll  1  A  V"™  X  III  1  i\  A  ri  \  t~  j  J  f 

0RT9030 

V1XI    /  V  ^  V 

GO  TO  1250 

0RT9040 

r 

V 

0RT9050 

1990 

X  7  7  w 

FORMAT  (/35X,22HLEAST  SQUARES  FIT  FOR  ,12A1,11H  IN  COLUMN  ,14)  0RT9060 

fc.  v  U  U 

FORMAT  (25X,26HAS  A  POLYNOMIAL  OF  DEGREE  ,I2,4H  IN  ,12A1,11H 

IN  C00RT9070 

1LUMN  ,14) 

0RT9080 

2010 

FORMAT  (20X,6HUSING  ,I4,22H  N0N-ZER0  WEIGHTS  AND  ,I4,24H  ZERO 

WEIG0RT9090 

1HTS  IN  COLUMN  ,14) 

0RT9100 

2020 

FORMAT  (35X,6HUSING  ,I4,19H  N0N-ZER0  WEIGHTS  =,10A1) 

0RT9110 

2030    FORMAT  (60H0  PLOTS  ARE  NOT  PRINTED  BECAUSE  NO.  OF  POINTS  IS  LESS  T0RT9120 
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1HAN  3)  0RT9130 

2050    FORMAT  (23X,24HAS  A  LINEAR  FUNCTION  OF  ,I2,31H  PREDICTOR  VARI ABLES0RT9150 

1  IN  COLUMNS, I4,8(A1,I4) )  0RT9160 

2060  FORMAT   ( 14 , 24 (Al , 14 ) )  0RT9165 

END  0RT9170 
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SUBROUTINE  ORTHRV  (A ,NROW,N ,NCOL , IND ,X ,NASIZE ,XP) 

ORV 

10 

c 

VERSION    5.00          ORTHRV  5/15/70 

ORV 

20 

c 

SUBROUTINE  ORTHRV ( A , NROW, N , NCOL , IND , X , NAS IZE , XP ) 

ORV 

30 

c 

SUBROUTINE  TO  CHECK  TO  SEE  IF  MATRIX  IS  ORTHOGONAL 

ORV 

40 

DIMENSION  A(NR0W,1),  X(l),  IND  (1 ) 

ORV 

50 

DOUBLE  PRECISION  XP(1) 

ORV 

60 

c 

IF  NUMBER  OR  ROWS  IS  GREATER  THAN  NUMBER  OF  COLUMNS  COMPUTE  A' A 

ORV 

70 

c 

OTHERWISE  AA' 

ORV 

80 

IF  (N  .GT .NCOL)  GO  TO  10 

ORV 

90 

L2P=1 

ORV 

100 

MP=N 

ORV 

110 

GO  TO  20 

ORV 

120 

10 

L2P=2 

ORV 

130 

MP=NCOL 

ORV 

140 

20 

CALL  MXTXP  (A,NR0W,N,NC0L,X(L2P,NASIZE,XP) 

ORV 

150 

IC=1 

ORV 

160 

IND(1)=0 

ORV 

170 

IND (2 )=0 

ORV 

180 

DO  80  1=1, MP 

ORV 

190 

DO  80  J=1,MP 

ORV 

200 

IF  (I.EQ.J)  GO  TO  40 

ORV 

210 

IF  (X(IC))  30,80,30 

ORV 

220 

30 

IF  (ABS(X(IC) )-l.E-7)  60,60,90 

ORV 

230 

40 

IF   (X(IC)-l.O)  50,80,50 

ORV 

240 

50 

IF   (ABS(X(IC)-1.0)-l.E-7)  60,60,70 

ORV 

250 

60 

IND (2)=1 

ORV 

260 

GO  TO  80 

ORV 

270 

70 

IND(1)=2 

ORV 

280 

80 

IC=IC+1 

ORV 

290 

GO  TO  100 

ORV 

300 

90 

IND (1)=2 

ORV 

310 

IND(2)=2 

ORV 

320 

GO  TO  150 

ORV 

330 

100 

IF  (IND(l) .EQ.0.AND.IND(2) .EQ.l)  IND(1)=1 

ORV 

340 

IF  (N.EQ.NCOL)  GO  TO  150 

ORV 

350 

C 

SET  UP  INDICATORS  FOR  RECTANGULAR  MATRICES 

ORV 

360 

GO  TO  (110,130)  ,  L2P 

ORV 

370 

110 

IF  (IND(l) .EQ.l)  GO  TO  120 

ORV 

380 

IND(1)=3 

ORV 

390 

IND (2)=3 

ORV 

400 

GO  TO  150 

ORV 

410 

120 

INi?(l)=-3 

ORV 

420 

IND(2)=-3 

ORV 

430 

GO  TO  150 

ORV 

440 

130 

IF  ( IND (1 ) .EQ.l)  GO  TO  140 

ORV 

450 

IND { 1 )=4 

ORV 

460 

IND(2)=4 

ORV 

470 

GO  TO  150 

ORV 

480 

C 

* 

ORV 

490 

C 

IND(1)=0  EXACT  ORTHOGONAL 

ORV 

500 

c 

IND (1)=1  RELATIVE  (l.E-7)  ORTHOGONAL 

ORV 

510 

c 

IND (1)=2  NON-ORTHOGONAL 

ORV 

520 

c 

INDICATORS  FOR  RECTANGULAR  MATRICES 

ORV 

530 

c 

IND (l)=-3  RELATIVE  ORTHOGONAL  ROWWISE 

ORV 

540 

c 

IND (1)=3  EXACT  ORTHOGONAL  ROWWISE 

ORV 

550 

c 

IND ( 1 )=-4  RELATIVE  ORTHOGONAL  COLUMNWISE 

ORV 

560 

c 

IND  (1 )=4  EXACT  ORTHOGONAL  COLUMNWISE 

ORV 

570 

c 

IND (2)=-l  DIAGONAL  TERMS    ARE  1.0  SE 

ORV 

580 

c 

IND (2 )=0  EXACT  ORTHOGONAL  NORMALIZED 

ORV 

590 
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C         IND(2)=1  RELATIVE  ORTHOGONAL  NORMALIZED  ORV  600 

C         IND(2)=2  NON-ORTHOGONAL  ORV  610 

C  IND (2 )=-3  RELATIVE  ROWWISE  (NORMALIZED)  ORV  620 

C  IND (2)=3  EXACT  ROWWISE  (NORMALIZED)  ORV  630 

C         IND(2)=-4  RELATIVE  COLUMNWISE     (NORMALIZED)  ORV  640 

C         IND(2)=4  EXACT  COLUMNWISE  (NORMALIZED)  ORV  650 

C         *  ORV  660 

C         *  ORV  670 

140      IND(l)=-4  ORV  680 

IND(2)=-4  ORV  690 

150      RETURN  ORV  700 

END  ORV  710 
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SUBROUTINE  ORTPLT (  ND19 , ND2 , N , SSQ , ND3 , IB , I XA , I WS )  ORP  10 

C         VERSION    5.00         ORTPLT         5/15/70  ORP  20 

C         THIS  PROGRAM  IS  USED  BY  ORTHO  TO  GENERATE  PLOTS  ORP  30 

C         WRITTEN    BY  S  PEAVY         10/11/69  ORP  40 

DIMENSION  IU(1)  ,  IB (1 )  ORP  50 

EQUIVALENCE  (IU,A)  ORP  60 

C         *****  ORP  70 

C0MM0N/BL0CKD/IARGS(100) ,KIND(100) ,ARGTAB(100) ,NRMAX ,NROW,NCOL ,      ORP  80 

1NARGS , VWXYZ (8 ) ,NERROR  ORP  90 

C0MM0N/BL0CRC/NRC,RC(12600)  ORP  100 

COMMON/ HEADER /NOCARD (80 ) ,ITLE(60,6) , LNCNT , I  PR  I  NT ,NPAGE , I  PUNCH  ORP  110 

C0MM0N/SCRAT/NS,NS2,A(13500)  ORP  120 

COMMON /FMAT/ I FMTX (6) , IOSWT , IFMTS (6 ) , LHEAD (96 )  ORP  130 

DIMENSION  ARGS(IOO)  ORP  140 

EQUIVALENCE  (ARGS (1 ), RC (12501 ) )  ORP  150 

COMMON  /ABCDEF/L (48)  ORP  160 

COMMON/CONSTS/PI ,E,HALFPI , DEG , RAD , XALOG  ORP  170 

C         *****  ORP  180 

IW=IWS  ORP  182 

IWST=1  ORP  184 

IF(KIND(2) .EQ.O)  GO  TO  18310  ORP  186 

IWST=2  ORP  187 

WT=ARGS(2)  ORP  188 

18310  IND4  =  ND19+1  ORP  190 

IND2=ND2+1  ORP  200 

NZW=N  ORP  205 

DO  18320  1=1, N  ORP  210 

GO  TO  (18312,18314) ,IWST  ORP  211 

18312  WT=RC(IW)  ORP  212 

IW=IW+1  ORP  213 

18314  IF(WT.NE.O.O)     GO  TO  18316  ORP  214 

IU   (IND4)=27  ORP  215 

NZW=NZW-1  ORP  216 

GO  TO  18318  ORP  218 

18316  Z=A(IND4) /FSQRT (SSQ/WT-A ( IND2 ) **2 )  ORP  220 

IZ=Z  / .3  ORP  230 

IF  (Z.GT.O.O.AND.AMOD(Z, .3) . NE . 0 . 0 ) IZ=IZ+1  ORP  240 

IU(IND4)=IZ+13  ORP  250 

IF(IU(IND4) .LE.O)  IU(IND4)=1  ORP  260 

IF  (IU (IND4) .GT.26)  IU(IND4)=26  ORP  270 

18318  IND2=IND2+1  ORP  280 

18320  IND4=IND4+1  ORP  290 

IND3=ND3+1  ORP  300 

YMAX=A ( IND3 )  ORP  310 

YMIN=A(IND3)  ORP  320 

DO  18340  1=2, N  ORP  330 

IND3=IND3+1  ORP  340 

IF(YMIN.LE.A(IND3) )  GO  TO  18330  ORP  350 

YMIN=A ( IND3 )  ORP  360 

GO  TO  18340  ORP  370 

18330  IF (YMAX . LT . A ( IND3 ) )  YMAX=A ( IND3 )  ORP  380 

18340  CONTINUE  ORP  390 

YMM=ABS  (YMAX-YMIN)/50.  ORP  400 

YMX=FL0AT(N-l)/50.  ORP  410 

CALL  PAGE(O)  ORP  420 

IPL0T=1  ORP  430 

WRITE(IPRINT, 18350)  ORP  440 

18350  FORMAT (15X , 36HSTANDARDIZED  RESIDUALS  VS  ROW  NUMBER, 22X,  ORP  450 

1  42HSTANDARDIZED  RESIDUALS  VS  PREDICTED  VALUES)  ORP  460 
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18420 
18430 

19000 


18355  WRITE ( IPRINT , 18360 )    (L (39) , 1=1 ,88) 

18360  FORMAT (7X, 2 (1H+.9A1) , 1H+ , 4A1 , 1HX , 4A1 , 2 ( 1H+9A1 ) , 1H+ , 10X , 2 ( 1H+ , 9A1 ) 
1   ,1H+,4A1,1HX,4A1,2(1H+,9A1) ,1H+) 

YYPR=3 .75 

LINE=26 
18390  DO  20050  1=1,5 

DO  18400  IJ 1=1 , 102 
18400  IB (IJI )=L (45) 

GO  TO  (18410,19000) ,IPLOT 
18410  IND3=ND3+1 

IND4=ND19+1 

DO  18430  I J  1=1 , N 

IF (IU  (IND4) .NE.LINE)  GO  TO  18420 

IZ=FLOAT (IJI-1) /YMX  +.5 

IZ=IZ+1 

IF(IZ.LE.O)  IZ=1 
IF(IZ.GT.51)  IZ=51 
IB(IZ)=L(41) 
IZ=(A(IND3)-YMIN) /YMM 
IZ=IZ+1 

IF(IZ.LE.O)  IZ=1 
IF(IZ.GT.51)  IZ=51 
IB(IZ+51)=L(41) 
IND4=IND4+1 
IND3=IND3+1 
GO  TO  20000 
IND4=ND19+1 
IX=IXA 

DO  19010  IJ 1  =  1 , N 

IF(IU(IND4) .NE.LINE)  GO  TO  19005 

IZ=(RC (IX)-XMIN) /XMM 

IZ=IZ+1 

IF(IZ.LE.O)  IZ=1 

IF  (IZ.GT.51)  IZ=51 

IB ( IZ)=L (41 ) 

RAT  1 0= ( AN-GAMMA ) /FDEN 

YMM=4.91* (RATIO** .14- (1 .-RATIO)** .14) 

AN=AN-1.0 

IF  (AN.LT.2.    .AND.  NZW.LE.10)  GAMMA  =  1./3. 

IZ=YMM/ .1 

IZ=IZ+26 

IF (IZ.LE.O)  IZ=1 

IF(IZ.GT.51)  IZ=51 

IB(IZ+51)=L(41) 
19005  IX=IX+1 
19010  IND4=IND4+1 
20000  IF(I-l)  20010,20010,20030 

20010  WRITE  (IPRINT, 20020 )YYPR, ( IB ( I J  I ) , IJ 1=1 , 51 ) , YYPR , (IB (IJI) , I J  1=52 , 
1  102) 

20020  F0RMAT(1X,F5.2,1H+,51A1 ,1H+,3X,F5 .2,1H+,51A1 ,1H+) 
GO  TO  20045 

20030  WRITE(IPRINT,20040)  ( IB ( I J I ) , I J  1=1 , 102 ) 
20040  FORMAT (6X,1H-, 5 1A1 , 1H- , 8X , 1H- , 51A1 , 1H-) 
20045  LINE=LINE-1 

IF(LINE.EQ.O)  GO  TO  20060 
20050  CONTINUE 

YYPR=YYPR-1.5 
GO  TO  18390 
20060  WRITE ( IPRINT , 18360 ) 


(L (39) , 1=1 ,88) 


ORP  470 
ORP  480 
ORP  490 
ORP  500 
ORP  510 
ORP  520 
ORP  530 
ORP  540 
ORP  550 
ORP  560 
ORP  570 
ORP  580 
ORP  590 
ORP  600 
ORP  610 
ORP  620 
ORP  630 
ORP  640 
ORP  650 
ORP  660 
ORP  670 
ORP  680 
ORP  690 
ORP  700 
ORP  710 
ORP  720 
ORP  730 
ORP  740 
ORP  750 
ORP  760 
ORP  770 
ORP  780 
ORP  790 
ORP  800 
ORP  810 
ORP  820 
ORP  830 
ORP  840 
ORP  850 
ORP  860 
ORP  870 
ORP  880 
ORP  890 
ORP  900 
ORP  910 
ORP  920 
ORP  930 
ORP  940 
ORP  950 
ORP  960 
ORP  970 
ORP  980 
ORP  990 
0RP1000 
0RP1010 
0RP1020 
0RP1030 
0RP1040 
0RP1050 
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GO  TO  (20070,21100  ) ,IPLOT 
20070  YMM=YMX*25.0  +1.0 

YMMY=  (YMAX-YMIN) /2 .+YMIN 

WRITE ( I  PR INT , 20080 )  YMM,N , YMIN , YMMY , YMAX 

FORMAT (6X,3H1.0,18X,F9.4,16X, 15, 2H.0  , 1PE15 . 4 , E26 . 4 , 10X  ,  E10  . 4 ) 
WRITE  (IPRINT, 20090) 


20080 
20090 


FORMAT   (1H  ) 
IPLOT=2 
IX=IXA 
XMAX=RC(IX) 
XMIN=RC(IX) 
DO  21000  1=2, N 
IX=IX+1 

IF (RC (IX) .GT.XMAX)  XMAX=RC(IX) 
IF(XMIN.GT.RC(IX) )  XMIN=RC(IX) 
21000  CONTINUE 

XMM  =  ABS  (XMAX-XMIN) /50. 

GAMMA=P 1/8.0 

AN=NZW 

FDEN=AN-2 . *GAMMA+1 . 0 

WRITE (IPRINT, 21010)   (LHEAD(I) ,1=13,24) 
21010  FORMAT (14X , 26HSTANDARDIZED  RESIDUALS  VS  ,12A1,  21X, 
1  42HPR0BABILITY  PLOT  OF  STANDARDIZED  RESIDUALS) 

GO  TO  18355 
21100  YMMY=( XMAX-XMIN)  /2.+XMIN 

WRITE (IPRINT, 21110)  XMIN ,YMMY ,XMAX 
21110  F0RMAT(1PE13 .4,14X,  E12.4,  8X,  E12 . 4 , 7X , 4H-2 . 5 , 22X , 3H0 . 0 , 22X , 
1  3H2.5) 

RETURN 

END 


0RP1060 
0RP1070 
0RP1080 
0RP1090 
0RP1100 
0RP1110 
0RP1120 
0RP1130 
0RP1140 
0RP1150 
0RP1160 
0RP1170 
0RP1180 
0RP1190 
0RP1200 
0RP1210 
0RP1230 
0RP1240 
0RP1245 
0RP1250 
0RP1270 
0RP1280 
0RP1290 
0RP1300 
0RP1310 
0RP1320 
0RP1330 
0RP1340 
0RP1350 
0RP1360 
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WRITE  (ISCRAT,40)  I,NEWC0 
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IVU 

GO  TO  10 
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p 
L 

OUT 
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civ 

^  a 
30 

FORMAT  (4X.80A1) 
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O  O  A 
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40 

FORMAT  (1H+,I3,80A1) 

OUT 
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END 
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SUBROUTINE  PACK  (NWORD , MWORO , NO , I P )  PAC  10 

C          VERSION    5.00          PACK             5/15/70  PAC  20 

C          WRITTEN  BY  S  PEAVY     9/17/69  PAC  30 

C         NWORD      CONTAINS  CHARACTERS  TO  BE  PACKED  OR  UNPACKED  PAC  40 

C         MWORD      THE  PACKED  CHARACTERS  IN  CODED  FORM  (SEE  BELOW)  OR  THE        PAC  50 

C                      UNPACKED  CHARACTERS  PAC  60 

C         NO           NO  OF  CHARACTERS  TO  BE  PACKED  OR  UNPACKED  PAC  70 

C         IP           IP=0    PACK  PAC  80 

C         IP           IP=1      UNPACK  PAC  90 

C  PAC  100 

C         THE  CHARACTERS  ARE  PACKED  IN  A  CODED  FORM.  EACH  CHARACTER  HAS  BEENPAC  110 

C         ASSIGNED  A  VALUE  IN  OMCONV .  THIS  VALUE  IS  1  LESS  THAN  THE  PAC  120 

C         SUBSCRIPT  OF  L  (IN  LABELED  COMMON  ABCDEF)  FOR  THAT  PARTICULAR  PAC  130 

C         CHARACTER.  THESE  VALUES  ARE  STORED  IN  KARD.  THE  VALUES  OF  THE  PAC  140 

C         CHARAC1 ERS  ARE  PACKED  AS  FOLLOWS  PAC  150 

C                        MW0RD(I)=(KARD(K)+l)*2**16+(KARD(K-l)+l)*2**8+KARD(K-2)+lPAC  160 

C  PAC  170 

COMMON  /ABCDEF/  L(48)  PAC  180 

DIMENSION  NWORD(l),  MWORD(l)  PAC  190 

KB=1  PAC  200 

KA=1  PAC  210 

IF   (IP.EQ.l)  GO  TO  30  PAC  220 

C         PACK  PAC  230 

10        MWORD (KA)=0  PAC  240 

DO  20  1=1,3  PAC  250 

MW0RD(KA)=MW0RD(KA)*256+NW0RD(KB)+1  PAC  260 

KB=KB+1  PAC  270 

IF (KB .GT  .NO)     GO  TO  22  PAC  280 

20        CONTINUE  PAC  290 

KA=KA+1  PAC  300 

GO  TO  10  PAC  310 

22    ICE=M0D(N0,3)  PAC  311 

IF(ICE.EQ.O)  RETURN  PAC  312 

ICE=3-ICE  PAC  313 

24    MWORD (KA)=MWORD (KA) *256+45  PAC  314 

ICE=ICE-1  PAC  315 

IF  (ICE.EQ.O)  RETURN  PAC  316 

GO  TO  24  PAC  317 

C         UNPACK  PAC  320 

30        ICA=NWORD(KB)  PAC  330 

ICD=65536  PAC  340 

DO  40  1=1,3  PAC  350 

ICB=ICA/ICD  PAC  360 

IF  (ICB.EQ.O)  GO  TO  40  PAC  370 

MWORD (KA)=L(ICB)  PAC  380 

KA=KA+1  PAC  390 

IF  (KA.GT.NO)  RETURN  PAC  400 

ICA=ICA-ICB*ICD  PAC  410 

40        ICD=ICD/256  PAC  420 

KB=KB+1  PAC  430 

GO  TO  30  PAC  440 

END  PAC  450 
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SUBROUTINE  PAGE  (J)  PAG  10 

C         VERSION    5.00         PAGE             5/15/70  PAG  20 

C  PAG  30 

C                BRING  UP  A  NEW  PAGE  AND  PRINT  OMNITAB  CARD  AND  PAGE  NUMBER        PAG  40 

C                THEN,  IF  J  =  0,  DONE  PAG  50 

C                             J  =  1 ,  PRINT  TITLE1  PAG  60 

C                               J  =  2,  PRINT  TITLEl ,  2  PAG  70 

C                                  ETC.  FOR  J  =  3,  4  PAG  80 

C         THIS  ROUTINE  ASSUMES  THAT  THE  EXECUTIVE  SYSTEM  LEAVES                       PAG  90 

C         THE  PRINTER  FORM  AT  THE  TOP  OF  THE  FIRST  BLANK  PAGE.                         PAG  100 

COMMON/HEADER/NOCARD (80) ,ITLE(60,6) , LNCNT , I  PR  I  NT ,NPAGE , I  PUNCH         PAG  110 

NPAGE=NPAGE+1  PAG  150 

WRITE     (IPRINT,20)  NOCARD ,NPAGE  PAG  160 

IF  (J  .LE.O.OR.J  .GT.4)  GO  TO  10  PAG  180 

WRITE  (IPRINT,30)   ( ( ITLE ( 1 , 1 1 ) , 1=1 , 60 ) , 1 1=1 , J )  PAG  190 

10        RETURN  PAG  200 

C  PAG  210 

20        FORMAT  (1H1 , 19X , 80A1 , 10X , 4HPAGE  ,  14 )  PAG  220 

30        FORMAT  ( IX , 120A1 / IX , 120A1 )  PAG  230 

END  PAG  240 
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SUBROUTINE  PDMOTE 

PDM 

1  A 

10 

c 

VERSION    5.00  PDMOTE 

5/15/70 

nr\n 

PDM 

A  A 

20 

COMMON  /BL0CRC/  NRC  , RC  ( 12600 ) 

PDM 

">  A 

30 

COMMON  /BLOCKD /  IARGS(IOO) , KIND (100) , ARGTAB (100 ) , NRMAX ,NR0W,NC0L ,NPDM 

A  A 

40 

IARGS, VWXYZ(8) ,NERR0R 

n  nil 

PDM 

50 

DIMENSION  ARGS(IOO) 

d  n  ii 

PUM 

60 

EQUIVALENCE  (ARGS  (1 ), RC ( 12501  ) ) 

d  n  ii 

PDM 

70 

COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG 

r  UNI 

80 

L2=L2-10 

d  n  ii 

90 

A 

c 

r  UM 

1  A  A 

100 

C 

L2  :  0  FOR  PROMOTE,      1  FOR  DEMOTE        (  L2 

ADTPTMAIIV    in       11  \ 

UK  1 b 1 NALL  Y    10,    11  ) 

nnu 
PUM 

110 

A 

c 

r  UM 

120 

IF  (MOD (NARGS , 2 ) .NE.O)  GO 

TO 

Dnil 

PUM 

130 

1=10 

nnii 

r  UM 

1    i  n 

140 

10 

CALL  ERROR  (I) 

DrtM 
PUM 

150 

A  A 

20 

RETURN 

rum 

T  /  A 

160 

a 
30 

IF  (KIND (1 ) .EQ.l)  GO  TO  35 

DrtM 

PUM 

163 

NR  =  IARGS  (1) 

PUM 

1  T  A 

170 

IARGS(1)=1 

nnu 
PUM 

T  A  A 

180 

CALL  CHKCOL  (I) 

ddm 
rUM 

1  A  A 

190 

IF  (I.EQ.O)  GO  TO  40 

DDM 

r  UM 

200 

35 

I  =  20 

DrtM 
r  UM 

210 

GO  TO  10 

DrtM 

rUM 

220 

L 

DrtM 
r  UM 

AAA 

230 

L 

IF  NUMBER  OF  ROWS  TO  BE  MOVED 

IS  NEGATIVE, 

C I  TD    T  MCTDI IPT  T  ftWC 
rLir    i  No  1  KUL.  1  1  UNi  . 

r  UM 

A  A  A 

240 

L 

T   F       PRflMOTF     A     T  <;  THF 

SAME 

AS  DEMOTE 

6 

DIM! 

PUM 

A  C  A 

250 

A  A 

40 

TF   fNR  GF  n\  en  to 

nnu 
PUM 

260 

1  ?_1    1  0 

L-  L  —  X  — 1_  C 

nnu 
PUM 

270 

NR-  NR 

DrtM 
PUM 

280 

r  A 

50 

NARft^— NARG^  1 
Nftr\uj= niMnvaj  —  1 

pnu 

r  Um 

290 

C 

DrtM 
rum 

300 

c 

CWVCV.    nTQTAMTF    OF  Mfl\/F 

DDM 
r  UM 

OTA 

310 

c 

DrtM 
r  Um 

AAA 

320 

IF  (L2.EQ.0)  GO  TO  70 

DrtM 
r  UM 

330 

IF  (NR+NRMAX.LE.NROW)  GO 

TO  100 

DrtM 
rum 

340 

CALL  ERROR  (231) 

DrtM 
r  UM 

345 

NRMAX=NROW-NR 

DrtM 
PUM 

A  C  A 

350 

IF  (NRMAX)  20,20,100 

DrtM 
PUM 

A  r  T 

351 

70 

NDIFF  =  NRMAX-NR 

DrtM 
rUM 

A  C  C 

355 

IF  (NDIFF)  81,82,82 

DrtM 
r  UM 

A  Z  A 

360 

A  "I 

81 

CALL  ERROR  (230) 

DrtM 
r  UM 

a  /  e 

365 

NDIFF  =  0 

DrtM 
PUM 

370 

NR  =  NRMAX 

DrtM 
rUM 

A  "T  C 

375 

A  A 

82 

IF  (NARGS. GT.O)  GO  TO  100 

nnu 
PUM 

AAA 

380 

J  =  IARGS  (1)-1 

DrtM 
PUM 

IOC 

385 

DO  95  11  =  1,NC0L 

run 

AAA 

390 

Kl  =  J+l 

DrtM 
PUM 

O  A  C 

395 

IF  (NDIFF. EQ.O)  GO  TO  86 

DrtM 
rUM 

400 

K2  =  Kl  +  NR 

DrtM 
PUM 

A  T  A 

410 

DO  85  12  =  1, NDIFF 

DrtM 
r  UM 

A  1  A 

RC(K1)  =  RC(K2) 

DrtM 
r  UM 

#1  1  c 

425 

Kl  =  Kl+1 

n  n  II 
PUM 

430 

A  r 

85 

K2  =  K2+1 

nnu 
PUM 

4  A  C 

435 

A  L 

86 

DO  90    13  =  1,NR 

nnu 

PDM 

VI  it  A 

440 

RC(K1)  =  0.0 

PDM 

j  ja  r 

445 

A  A 

90 

Kl  =  Kl  +1 

PDM 

J  PA 

450 

A  C 

95 

J  =  J  +  NROW 

PDM 

A  /  A 

460 

GO  TO  20 

PDM 

470 

100 

LIMIT=NARGS 

PDM 

480 
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IC     /I  TMTT    Cn    Al     1  TMIT    O  +  MPPI 
lr    (L.1M1I  .  ty  .  0 )    L  1  Ivu  1  =Z  NILUL 

DnM 

r  UM 

4  V  0 

I  r     /MPDDnD    MP    A\    Pf\    Tfl  OA 
lr     ( NC.KKUK  .  nt  .  U  )    bU    IU  ZO 

DnM 
rUNI 

C  A  A 

500 

tp   imdmay  MP  ai  pn  Tn  1 1  n 
lr    ( NKMAA  . IMt  .  U  )    bU    IU  110 

DnM 
r  UM 

CIA 

310 

p n  Tfi  in 
bU    IU  10 

DnM 
r  UM 

C  *)  A 

bZO 

p 
b 

DnM 
r  UM 

3JU 

p 
t 

CTADT    DDfl  MO  T  T  M  P    flD    DC  MP  TTklf 
0  1  AK  1    rKUMUIlrvb  UK  UtMUllNb 

onM 
r  UM 

C  A  A 

p 
b 

DnM 
r  UM 

CCA 

DD0 

J.  1 U 

nn   1  cn    T_l    1  TMTT  9 
UU    100    1  =  1  , LI  ml  1  ,  Z 

DnM 

c  a  n 

300 

TP    fNARG^   NP    ni    GO.   Tfl    1  ?n 

r  v  vn 

c.7n 

If  1     T  ADf  C  f  1  \ 

pnu 

con 

SOU 

If  9  —If  1 
r\  £ =r\  1 

PDM 

con 

I  ADfC  M  \     T  A  DP  C  /  1  1  .  M  DniU 
IAKuj (1 )=lAKu J (1 J +NKU n 

DnM 

rUm 

AAA 
QUO 

fin  th  iin 

PDM 

a  i  n 

0  1  u 

If  1  —  T  ARG^  /  lil  \ 

M=lnRUJ  ^  1+1  J 

rum 

If  7     T  ADP  Q  f  1  ,51 
l\Z=lAKbj  I  1  +  Z  ) 

pnM 
r  Um 

a  %  n 

1  jU 

tp    /io  pn  a\   pn  xn  i  c  a 
lr    (LZ.ty.U)   bU   IU  lt>0 

DnM 
r  UM 

A  A  A 
0^0 

p 
b 

DnM 
r  UM 

A  C  A 
0  3  0 

P 
b 

n p un tp  pni    at  if  i  Tn  pni    at  if  9 

UtMU  1  t   bUL   Al    M    IU   bUL   Al  l\Z 

pnu 

A  A  n 
000 

b 

DnM 
r  UM 

A  7  A 
0/0 

If  1  —If  1  iNPUAY 

pnM 

r  UIVI 

Ann 

DOU 

If  7    If  0  i  MDMA  V  i  KID 
N  Z  =N  Z +N  K  MA  A +N  K 

DnM 
r  UM 

A  0  A 
070 

fin    1  Aft     1     1     MDMA  V 
UU    110  J=1,NKMAA 

DnM 
r  UM 

7  A  A 
/  00 

If  1    If  1  1 
f\  l=rv  1  —  1 

DnM 
r  UM 

7  1  A 
/  1  0 

If?— 1 

PDM 

r  u  vn 

7?n 

i  An 

11U 

OC  1  If  7  1  —DP  1  If  1  \ 
Kb          J  =Kb  [M  J 

pnM 

r  U  Ifi 

7^n 

p n  Tn  ion 
bU    1 U  loU 

DnM 
r  UM 

7  A  A 

/  tu 

p 
b 

DnM 
r  UM 

7  C  A 
/DO 

p 
b 

DcnufiTr  pni    at  ifi  Tn  pni    at  v? 

rKUMU 1 t   bUL   Al    M    IU   bUL   Al  l\Z 

pnM 

r  UM 

7  AA 

p 
b 

pnM 

r  UM 

7  7  n 
/  /  U 

1  D  U 

1 1    MDMAV  MD 
J  J=NKMAA— NK 

pnM 

r  uim 

7  q  n 

/  OU 

tp   /  i  i  pn  ai  pn  Tn  uc 
lr   ( J  J  . ty  .  u  )  bU  iu  io? 

pnM 

r  uwi 

7  fi  C 
/  03 

If  1     V  1  ■  MD 

pnM 

rUM 

7on 

no  i An   i—T    i  i 

UU    10U    J  —  1  ,  J  <J 

PDM 

rum 

OwU 

or  iv o  \  dp  f if  1 1 
Kb  {l\Z  ;=Kb  (M  ; 

PDM 
r  UIVI 

q  i  n 

0  1  u 

if  i  —if  i  1 1 
M=M  +  1 

pnM 

r  UIVI 

a?n 

0  A  U 

1  £  A 

160 

If  7        7  .  1 

l\Z=KZ+l 

pnM 

r  UM 

Q  1 A 
0  J\) 

p 

pnM 

r  UM 

0  A  A 

otu 

p 
b 

TP    D  D  n  un  TP    ADDAV      PTII     DPCT    fIC    Pnill  MM    lAITTkl  7PD0PQ 
lr   rKUMU  1 1  AKKAY  ,    rlLL   Kt.il    Ur   bULUMN   Wlln  ZtKUto  . 

pnM 

r  u  wi 

sen 

OjU 

p 
b 

Pf)M 

r  v  vn 

RAH 
0  0  U 

tp   /madpc  mp  n\  nn  Tn  inn 

ir     l  NAKuj  .  Nt  . U  J    bU    IU  10U 

PDM 

rum 

O  1  u 

lOD 

II  11,1 

J J=J J+l 

pnM 

r  Um 

RRn 

oOU 

nn    1  7(1     1—  i  1  MDMAV 
UU    1/0    J=J  J  ,  PmiYlMA 

pnM 

rum 

O  7  v 

DP  /  V 0  \  A 

Kb  ( KZ ) =0 . 

pnM 

rum 

onn 

1  "7  A 
170 

If  9     If  9  .  1 

KZ=KZ+1 

pnM 

r  UWI 

o  i  n 

71U 

1  0  A 

loO 

PPMT  T  Ml  IP 

bUN  1 1 nut. 

pnM 

rum 

7tU 

TP     l\  7    MP    A  \     MDMAV    MDMAV, MD 
lr    (LZ.Nt.U)  NKMAa=NKMAA+IMK 

pnM 

r  uwi 

o  n 

73U 

GO  TO  20 

pnM 
r  UM 

OAA 
7^0 

END 

PDM 

950 

234 


SUBROUTINE  PHYCON  (NAME1 

j  u  i_>  i\  \j  u  i  i  ii  l    r  ii  i  v  vi»     \  iv  n  if il.  / 

PHY 

10 

c 

VERSION     5.00          PHYCON  5/15/70 

PHY 

20 

COMMON  /BLOCKA/  MODE , M, KARD (83 ) , KARG , ARG , ARG2 , NEWCD (80 ) , KRDEND 

PHY 

30 

COMMON /PCONST /JPC  P(40)  N(40) 

PHY 

40 

c 

REMOVE 

PHY 

50 

c 

PHY 

60 

p 

PHYSICAL  CONSTANT  LIST 

PHY 

70 

r 

PHY 

80 

r 

ENTRIES  ARE  IN  PAIRS,  FIRST  MKS  VALUE,  THEN  CGS 

(ELECTROMAGNETIC) 

PHY 

90 

c 

PHY 

100 

r 

PHY 

110 

c 

PI  PI 

PHY 

120 

c 

E                BASE  OF  NATURAL  LOGS 

PHY 

130 

c 

C                SPEED  OF  LIGHT  IN  VACUUM 

PHY 

140 

c 

Q                ELEMENTARY  CHARGE 

PHY 

150 

c 

N                AVOGADRO  CONSTANT 

PHY 

160 

c 

ME              ELECTRON  REST  MASS 

PHY 

170 

c 

MP              PROTON  REST  MASS 

PHY 

180 

c 

F                FARADAY  CONSTANT 

PHY 

190 

c 

H                PLANCK  CONSTANT 

PHY 

200 

c 

ALPHA         FINE  STRUCTURE  CONSTANT 

PHY 

210 

c 

QME             CHARGE  TO  MASS  RATIO  FOR  ELECTRON 

PHY 

220 

c 

RINF           RYDBERG  CONSTANT 

PHY 

230 

c 

GAMMA         GYROMAGNETIC  RATIO  OF  PROTON  (CORRECTED 

FOR 

H20) 

PHY 

240 

c 

MUB            BOHR  MAGNETON 

PHY 

250 

c 

R                GAS  CONSTANT 

PHY 

260 

c 

K                BOLTZMANN  CONSTANT 

PHY 

270 

c 

CONE           FIRST  RADIATION  CONSTANT 

PHY 

280 

c 

CTWO           SECOND  RADIATION  CONSTANT 

PHY 

290 

c 

SIGMA         STEPHAN-BOLTZMANN  CONSTANT 

PHY 

300 

c 

G                GRAVITATIONAL  CONSTANT 

PHY 

310 

c 

PHY 

320 

c 

PHY 

330 

c 

IF  NAME  .LE.  0,  NAME  =  INDEX  FROM  MKS, CGS    0  = 

CGS, 

-1  = 

MKS 

PHY 

340 

c 

PHY 

350 

J=JPC 

PHY 

355 

IF  (NAME.GT.O)  GO  TO  10 

PHY 

360 

JPC=NAME 

PHY 

370 

RETURN 

PHY 

380 

10 

DO  20  1=1,20 

PHY 

390 

IF  (NAME.EQ.N(I) )  GO  TO  30 

PHY 

400 

20 

CONTINUE 

PHY 

410 

ARG=0 . 

PHY 

420 

RETURN 

PHY 

430 

30 

I=I+I+J 

PHY 

440 

ARG=P(I) 

PHY 

450 

RETURN 

PHY 

460 

END 

PHY 

470 
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c 
c 
c 
c 


c 
c 
c 


BLOCK      DATA  PHYSIC 

VERSION    5.00         PHYSIC  5/15/70 

BLOCK  DATA  PHYSICAL  CONSTANTS 

(THEIR  VALUES  AND  NUMBER  REPRESENTATION) 

BLOCK  DATA 

C0MM0N/PC0NST/JPC,P(40)  ,N(40) 

PCONST    DEFINES  PHYSICAL  CONSTANT  VALUES 

SI  UNITS  C6S  UNITS 

SEE  BELOW  FOR  FURTHER  COMMENTS 


c 

V 

PI 

Pi  l \— 1 

p 

c 

—  J  .  X*tX.J7£0.?.?-J 

r 
\j 

F 

P(  3)=2 

.718281828459 

P 

r 

1  4 

|_9    71 R  9  R  1 R  7  Rd  e;Q 

r 

r 
\f 

P(  5)=2 

.997925E8 

p 

r 

O 

—  L  .77' 

c 

n 

P(  7)=1 

.60210E-19 

P 

r 

<  R 
o 

i—i  Afi?inF  ?  n 

c 

N 

P(  9)=6 

.02252E23 

P 
r 

1 1  0 

c 

ME 

ML. 

P(ll)=9 

1091E-31 

P 

r 

(  X  L. 

i _g   i  n<J  1  F  ? R 

—  7  .  X  V  7  1 L — CO 

r 

MP 

P(13)=l 

67252E-27 

P 

1 1  4 

r 

F 

1 

P(15)=9 

64870E4 

D 
I 

-QMO  7n 

c 

H 

1  1 

P(17)=6 

6256E-34 

P 

f  1  R 

—  O  .  U  L.  J  O  C  —  CI 

c 

ALPHA 

P(19)=7 

29720E-3 

P 

i_7   ?Q7?(iF  3 

c 

QME 

P(21)=l 

758796E11 

P 

(22 

=17587960 

c 

RINF 

P(23)=10973731. 

P 

(24 

(=109737 .31 

c 

GAMMA 

P(25)=2 

67519E8 

P 

(26 

=26751  .9 

c 

MUB 

P(27)=9 

2732E-24 

P 

(28 

=9  .2732E-21 

c 

R 

P(29)=8 

3143 

P 

(30 

=8.3143E7 

c 

K 

P(31)=l 

38054E-23 

P 

(32 

=1.38054E-16 

c 

CONE 

P(33)=3 

7415E-16 

P 

(34 

=3  .7415E-5 

c 

CTWO 

P(35)=l 

43879E-2 

P 

(36 

=1 .43879 

c 

SIGMA 

P(37)=5 

6697E-8 

P 

(38 

=5.6697E-5 

c 

G 

P(39)=6 

670E-11 

P 

[40 

=6.670E-8 

DATA  P(l)  ,P(2)  ,P(3) ,P(4) ,P(5) ,P(6) ,P(7) ,P(8 

,P(9)  ,P(10)/ 

12*3  .1415926535,2*2.718281828459,2 .997925E8 ,2 .997925E10, 
2  1 .60210E-19.1 .60210E-20,2*6.02252E23/ 
DATA  P(ll) ,P(12) ,P(13) ,P(14) ,P(15) ,P(16) ,P(17) ,P(18) ,P(19) ,P(20)/ 

1  9.1091E-31,9 .1091E-28,1 .67252E-27 ,1 . 67252E-24 , 9 . 64870E4 , 9648 . 70 , 

2  6.6256E-34,6 . 6256E-27 , 2*7 .29720E-3/ 

DATA  P(21) ,P(22) ,P(23)  ,P(24) ,P(25)  ,P(26) ,P(27) ,P(28) ,P(29) ,P(30) / 

1  1.758796E1 1,17587960. ,10973731. , 109737 . 31 , 2 . 67519E8 , 26751 . 9 , 

2  9.2732E-24,9 . 2732E-21 , 8 . 3143 , 8 .3143E7/ 

DATA  P(31)  ,P(32) ,P(33) ,P(34) ,P(35) ,P(36) ,P(37) ,P(38) ,P(39) ,P(40)/ 

1  1 .38054E-23 ,1 .38054E-16,3 .7415E-16,3 .7415E-5 ,1 .43879E-2,1 .43879 , 

2  5.6697E-8. 5 .6697E-5.6 .670E-11.6 .670E-8/ 

DATA  N(l) ,N(2) ,N(3) ,N(4) ,N(5) ,N(6) ,N(7) ,N(8) ,N(9) ,N(10)/ 
1  11907,3645,2187,12393,10206,9612,9909,4374,5832,1069/ 

DATA  N(ll) ,N(12) ,N(13) ,N(14) ,N(15) ,N(16) ,N(17) ,N(18) ,N(19) ,N(20)/ 
1  12749,13379,5143,10046,13122,8019,2606,2750,14101,5103/ 
PHYSICAL  CONSTANTS  INTEGER  REPRESENTATION 


c 

N  (1)  = 

11907= 

PI 

(PI) 

c 

N  (2)  = 

3645= 

E 

(BASE  OF  NATURAL  LOGS) 

c 

N  (3)  = 

2187= 

C 

(SPEED  OF  LIGHT  IN  VACUUM) 

c 

N  (4)  = 

12393= 

Q 

(ELEMENTARY  CHARGE) 

c 

N  (5)  = 

10206= 

N 

(AV0GADR0  CONSTANT) 

c 

N  (6)  = 

9612= 

ME 

(ELECTRON  REST  MASS) 

C 

N  (7)  = 

9909= 

MP 

(PROTON  REST  MASS) 

c 

N  (8)  = 

4374= 

F 

(FARADAY  CONSTANT) 

c 

N  (9)  = 

5832= 

H 

(PLANCK  CONSTANT) 

C 

N(10)= 

1069= 

ALPHA 

(FINE  STRUCTURE  CONSTANT) 

C 

N(ll)= 

12749= 

QME 

(CHARGE  TO  MASS  RATIO  FOR  ELECTRON) 

c 

N(12)= 

13379= 

R  J  W  F 

(RYDBERG  CONSTANT) 

PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 
PHC 


10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
180 
190 
200 
210 
220 
230 
240 
250 
260 
270 
280 
290 
300 
310 
320 
330 
340 
350 
360 
370 
380 
390 
400 
410 
420 
430 
440 
450 
460 
470 
480 
490 
500 
510 
520 
530 
540 
550 
560 
570 
580 
590 


236 


c 

N(13)= 

5143= 

GAMMA 

(GYROMAGMETIC  RATIO  OF  PROTON-CORRECTED  FOR  H20) 

PHC 

600 

c 

N  (14)  = 

10046= 

MUB 

(BOHR  MAGNETON) 

PHC 

610 

c 

N  (15)  = 

13122= 

R 

(GAS  CONSTANT) 

PHC 

620 

c 

N  (16)  = 

8019= 

K 

(BOLTZMANN  CONSTANT) 

PHC 

630 

c 

N  ( 17  )  = 

2606= 

CONE 

(FIRST  RADIATION  CONSTANT) 

PHC 

640 

c 

N  (18)  = 

2750= 

CTWO 

(SECOND  RADIATION  CONSTANT) 

PHC 

650 

c 

N  (19)  = 

14101= 

SIGMA 

(STEPHAN-BOLTZMANN  CONSTANT 

PHC 

660 

c 

N  (20)  = 

5103= 

G 

(GRAVITATIONAL  CONSTANT) 

PHC 

670 

END 

PHC 

680 

409-118  OL  -  71  -  16 


237 


SUBROUTINE  PLOT                                                                                       PLO  10 

C  VERSION    5.00         PLOT             5/15/70                                                   PLO  20 

C  S  PEAVY          1/18/68                                                                                PLO  30 

C  THIS  ROUTINE  PLOTS  MAX.  OF  5  CURVES.  IF  MORE  THEN  ONE  POINT  FALLS  PLO  40 

C  ON  THE  SAME  POSITION  A  TALLY  IS  KEPT  AND  THE  NUMBER  IS  PRINTED.      PLO  50 

C  THE  USER  MAY  PROVIDE  THE  BOUNDS  ON  THE  X,Y  COORDINATES.                    PLO  60 

C  IF  BOUNDS  ARE  PROVIDED , THEY  MUST  APPEAR  IN  PAIRS  AS  READ  NOS .  IF  APLO  70 

C  PAIR  OF  REAL  NOS  ARE  EQUAL  THE  PROGRAM  ASSUMES  THERE  ARE  NO  BOUNDSPLO  80 

C  COMMANDS  FOR  USING  THIS  PLOT  ARE  AS  FOLLOWS                                        PLO  90 

C  FOR  THE  AXIS  THAT  PAIR  REPRESENTS  AND  THE  BOUNDS  WILL  BE  CALCULAT-PLO  100 

C  ED.                                                                                                           PLO  110 

C  COMMANDS  FOR  USING  PLOT  ARE  AS  FOLLOWS                                                PLO  120 

C  I  PLOT  Y  +++,+++, 

C  II        PLOT  Y  +++,+++, 

C  III      PLOT  Y  +++,+++, 


C  IV        PLOT  Y  +++,+++, 

C         V         PLOT  Y  +++,+++, 


X  +++  PLO  130 

. , (YMIN ,YMAX )  X  +++  (XMIN,XMAX)  PLO  140 

.  , (YMIN , YMAX )  X  ++1  PLO  150 

.  v  +++  (XMIN,XMAX)  PLO  160 

.  X  (XMIN,XMAX)   (YMIN ,  YMAX )  PLO  170 

C  PLO  180 

C         ERRORS  PLO  190 

C          I     WHEN  TYPE  II  COMMAND  IS  USED  THERE  MUST  BE  TWO  PAIRS  OF  REAL      PLO  200 

C              NOS.  OTHERWISE  THE  FOLLOWING  MESSAGE  IS  PRINTED  PLO  210 

C                    '  Y  BOUNDS  ARE  NOT  SET  UP  CORRECTLY'  PLO  220 

C           I     IF  BOUNDS  ARE  PROVIDED,  THEN  THERE  MUST  BE  FOUR  REAL  NOS.  PLO  230 

C          II     IF  A  SINGLE  REAL  NO.  APPEARS  AHEAD  OF  COLUMN  NOS.,  THE  FOLLOW-PLO  240 

C  ING  MESSAGE  WILL  BE  PRINTED  AND  NO  PLOTTING  WILL  TAKE  PLACE      PLO  250 

C                    '  Y  BOUNDS  ARE  NOT  SET  UP  CORRECTLY'  PLO  260 

C          III  IF  A  PLOT  COMMAND  ENDS  WITH  ONE  REAL  NO,  THE  FOLLOWING  MESSAGEPLO  270 

C                WILL  BE  PRINTED  AND  PLOTTING  WILL  BE  TERMINATED  PLO  280 

C                    '  X  BOUNDS  ARE  NOT  SET  UP  CORRECTLY'  PLO  290 

C          IV     IF  MORE  THEN  5  PLOTS  ARE  REQUESTED  PER  GRAPH,  NO  GRAPH  WILL  BEPLO  300 

C                PRODUCED  AND  FOLLOWING  MESSAGE  WILL  BE  PRINTED.  PLO  310 

C                    '  MORE  THEN  5  PLOTS  WERE  REQUISTED  PER  GRAPH'  PLO  320 

COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG  PLO  330 

COMMON  /BLOCRC/  NRC , RC  ( 12600 )  PLO  340 

COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NPLO  350 

1ARGS ,VWXYZ (8 ) ,NERROR  PLO  360 

DIMENSION  ARGS(IOO)  PLO  370 

EQUIVALENCE  (ARGS ( 1 ), RC  ( 12501 ) )  PLO  380 

COMMON  /SCRAT/  NS , NS2 , A ( 13500 )  PLO  390 

COMMON  /HEADER/  NOCARD (80 ) , ITLE (60 , 6) , LNCT , I  PR  I NT ,NPAGE , I  PUNCH        PLO  400 

COMMON  /FMAT /  IFMTX (6 ) , IOSWT , IFMTS (6) , LHEAD (96)  PLO  410 

DIMENSION  TIT(60),  TITX(60)  PLO  420 

EQUIVALENCE  (TIT  ,  ITLE ( 1 , 6 ) ) ,   (TITX  ,  ITLE ( 1 , 5 ) )  PLO  430 

DIMENSION  X(l),  KCCL(6),  PRINT(lOl),  XP(6),  B00L(5),  IDGT(9)  PLO  440 

EQUIVALENCE  (RC  ( 1 ) , X (1 ) ) ,   (PRINT, A)  PLO  450 

INTEGER  PRINT ,BLANK  PLO  460 

EQUIVALENCE  (XO.XMIN),   (X1,XMAX),   (YO , YMIN) ,   (Yl , YMAX)  PLO  470 

DIMENSION  IH(12,8),  IPR(lOl)  PLO  480 

EQUIVALENCE  (LHEAD, IH),   (IPR,A(200))  PLO  490 

INTEGER  BOOL  PLO  500 

DATA  BOOL(l) , BOOL (2) , BOOL (3) , BOOL (4) , BOOL (5 ) /1H . , 1H* , 1H+, 1H , , 1H-/ , PLO  510 

1BLANK/1H  /  PLO  520 

DATA  IDGT(l) ,IDGT(2) ,IDGT(3) ,IDGT(4) ,IDGT(5) ,IDGT(6) , IDGT (7 ) , IDGT (PLO  530 

18) ,IDGT(9)/1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HX/  PLO  540 

C         INITIAL    SWITCHES  PLO  550 

DATA  IXPR/1HX/  PLO  560 

IF  (NRMAX. GT.O)  GO  TO  10  PLO  570 

CALL  ERROR  (9)  PLO  580 

RETURN  PLO  590 
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10 

I  SWT=1 

PLO  600 

I SWT1=0 

PLO  610 

XUP=1 .E+35 

ni   A      /  a  A 

PLO  620 

X00WN=-1 . E+35 

PLO  630 

YUP=1 . E+35 

n  s  A    /  a  a 

PLO  640 

YD0WN=-1 .E+35 

PLO  650 

NCN=0 

PLO  660 

IPT=100 

PLO  670 

IPTX=101 

r>  1   A     /  a  A 

PLO  680 

▼  i-       /ii      fcl  r~      /   \      A  A     T  A      A  A 

IF   (L2 . NE . 6 )  GO  TO  20 

n  i  a    /  a  a 

PLO  690 

IPT=60 

A  1    A      -7  A  A 

PLO  700 

IPTX=61 

PLO  710 

20 

IF  (NARGS.EQ.2)  GO  TO  50 

A  1    A      T  A  A 

PLO  720 

IF  (KIND (NARGS ) . EQ . 0 )  GO  TO  40 

A  1    A      "7  1  A 

PLO  730 

ir    ^rvinu  (nAnuj  )-mhu  ^hhuo  —  i  ; 

MP  n  \ 

A  f\ 

GO 

TO  680 

A  1    A      "/  A  A 

PLO  740 

c 

y  np  v  Rnnwn^  arp  ppnuTnpn 

A    UrV    1     DUUnilj    MrvC    rKUV  1ULU 

PLO  750 

IF  (KIND (NARGS-2 ) .EQ.0)  GOTO 

30 

PLO  760 

IF  (KIND (NARGS-3 ) .EQ.0)  GO  TO 

680 

PLO  770 

ISWT=5 

A  1    A      ■»  A  A 

PLO  780 

YUP=ARGS (NARGS) 

A  1    A      T  A  A 

PLO  790 

YD0WN=ARGS (NARGS-1 ) 

A 1    A  AAA 

PLO  800 

XUP=ARGS (NARGS-2) 

At    A       *~i  t  ft, 

PLO  810 

XD0WN=ARGS (NARGS-3) 

A 1    A  AAA 

PLO  820 

NARGS=NARGS-4 

A  1    A      A  *i  A 

PLO  830 

GO  TO  50 

A  1    A      O  A  A 

PLO  840 

A 

c 

X  BOUNDS  ARE  PROVIDED 

A  1    A      a  r  A 

PLO  850 

30 

ISWT=3 

A  1    A      A  /  A 

PLO  860 

XUP=ARGS (NARGS) 

A  1    A      A  A 

PLO  870 

XD0WN=ARGS (NARGS-1) 

A 1    A  AAA 

PLO  880 

NARGS=NARGS-2 

A 1    A  AAA 

PLO  890 

IF  (NARGS.EQ.2)  GO  TO  50 

A  1     A  AAA 

PLO  900 

c 

CHECK  TO  SEE  IF  THERE  ARE  Y  BOUNDS 

A  1    A      a  t 

PLO  910 

40 

IF  (KIND (NARGS-1 ) -KIND (NARGS- 

2)  .NE. 

0) 

a  A     t  A      /  T  A 

GO  TO  670 

A 1    A  AAA 

PLO  920 

IF  (KIND(NARGS-l) .EQ.0)  GO  TO 

50 

A  1    A      A  •>  A 

PLO  930 

c 

Y  LIMITS  ARE  PROVIDED 

ni  A     A  A  A 

FLU  940 

ISWT=ISWT+1 

A  1    A      A  C  A 

PLO  950 

YUP=ARGS (NARGS-1) 

A  1    A      A  /  A 

PLO  960 

YDOWN=ARGS (NARGS-2) 

A  1    A      A  ^  A 

PLO  970 

IARGS (NARGS-2 )=IARGS (NARGS) 

A 1    A  AAA 

PLO  980 

KIND(NARGS-2)=0 

A  II    A  AAA 

PLO  990 

NARGS=NARGS-2 

A  1    A  1  A  A  A 

PLO1000 

50 

DO  60  1=1, NARGS 

A  1    A  1  A  1  A 

PLO1010 

60 

KCCL(I)=IARGS(I) 

A  1    A  1  A  A  A 

PLO1020 

M=NARGS-1 

AH    A  "1  A  O  A 

PLO1030 

IF  (NARGS. GT. 6)  GO  TO  710 

At    A  T  A  A  A 

PL01040 

CALL  CHKCOL  (J) 

A  1   A  1  A  (~  A 

PLO1050 

IF  (J.GT.O)  GO  TO  690 

A  1    A  T  A  /  A 

PLO1060 

c 

NO  ERROR  FOUND  IN  COLUMN  NOS . 

A  1    A  T  A  T  A 

PLO1070 

IF  (NERROR.GE.l)  RETURN 

A  1    A  1  A  A  A 

PLO1080 

A 

c 

SEARCH  FOR  MAX  AND  MIN  ON  AXIS,  IF 

BOUNDS  ARE 

hat    nnAw  t  nrn 

NOT  PROVIDED, 

r>  1   A  1  A  A  A 

PLO1090 

A 

c 

OTHERWISE  TALLY  NO  OF  POINTS 

THAT  FALL 

OUTSIDE 

AC  DAIIkinC 

Or  BUUNUb 

D  1  A  1  1  A  A 

r LU 1 1 OO 

IF  (XUP.GE.XDOWN)  GO  TO  70 

A  1  A  1  1  1  A 

PLO1110 

XAP=XD0WN 

A  1    A  1  1  A  A 

PL01120 

XAN=XUP 

A  1    A  T  1  A 

PL01130 

GO  TO  80 

A  1    A  1  1  A  A 

PL01140 

70 

XAP=XUP 

A I  At  i  c  a 

PLUl 150 

XAN=XD0WN 

A 1   A  1  1  /  A 

PL01160 

80 

IF  (YUP.GE.YDOWN)  GO  TO  90 

PL01170 

YAP=YD0WN 

PL01180 
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YAN=YUr 

n 1   A i  inn 

PL01190 

PA     T  A     1  A  A 

bU    IU  100 

ni   A  1  A  A  A 

PLO1200 

n  A 

90 

win    \y  M  D 

YAr=YUr 

HI    A)  T  A  1  A 

PL01210 

v a m  vnnuiu 
YAIN=YUUriN 

□  1    A  1  A  A  A 

HLU1Z20 

100 

1/1  TADPC/AIADPCx 

Kl=lAKbb  (NAKbb) 

ni  i  a  i  a  a  a 

PL01230 

I/O     1/1      1   .  KID  MA  V 

K2=K1-1+NKMAX 

HI    A  1  A  A  A 

PL01240 

T  C      /  T  C  U/T    0\      11A     7  O  A  1CA 

lr    (loWI-Z)  110,710,150 

n  1   A  1  A  C  A 

PLU1250 

1  1  A 

110 

VI      V  /  1/  1  \ 
A  1  =  A  (M  ) 

n  1  A  1  A  Z  A 

PLU1260 

V  A  VI 

X0=X  1 

n  1  A  1  A  T  A 

PLU1270 

nn  i  in   t   i/i  tfo 

n i  Anon 
HLU1280 

i  r    /vi    cc   v  /  t  \  \    rn  to  nn 
lr    (XI  .  bt . X  ( 1 ) )   bU    IU  1Z0 

n  1    A  1  A  A  A 

PLU1290 

VI      V  /  T  \ 
X1  =  X ( 1 ) 

ni  A  1  "5  A  A 

PLU1300 

p a  Tft  iia 
bU    1 U  13U 

A  1   A  1  A  1  A 

PLU1310 

1  0  A 

1ZU 

T  c     (Vn    1  c    Y  /  T  \  \    PA    Tf!    1  1  A 

lr    ( AO . Lt . A  ( 1  )  )   bU    IU  130 

d i ni iia 
HLU1320 

V  A     V  /  T  \ 

X0=X ( 1 ) 

O  1  A  1  1  1  A 

PLU1330 

1  1  A 

130 

A  A  M  T  T  Al  1  1 C 

LUN 1 1  Nut 

A  1    A  T  A  il  A 

PL01340 

140 

V  A  D  VI 

XAr=Xl 

A  1    A  1  A  r  A 

PL01350 

V  A  M    V  A 

AAN=AU 

D  1   A  1  O  L  C\ 

f  ft    TH      Mlrt     O  7  A     1  £  A     1  7  A     ">  7  A  \ 

bU    IU    ( 17U , if  0 , 160 , 2/0  ,  Z70 )  , 

T  C  UIT 

1  on  1 

A  1  A  1  A  7  A 

PLU1370 

1  L  A 

ioU 

l\t  Y=Z 

A  1  A  1  1  Q  A 

pn    TA    1  O  A 

bU    IU  180 

A  1    A  1   A  A  A 

PLU1390 

170 

1/  C  V  1 

Nh  Y  =  l 

A  1    A  1  A  A  A 

PL01400 

1  Q  A 

n  a  o£.n    i   i  u 
UU    £OU   J  =  i , M  • 

A  1  A  1  A  1  A 

r LU141U 

M=lAKbO  ( INAKbo  ) 

A  1   A  1  A  A  A 

1/1     T  ADPC  /  I  \ 
N3=l AKbo (J ) 

D  1  A  1  /l  3  A 

U  A    1/1    1  .  MDMA  V 

K4=K3-1+NKMAX 

D  1   A      A  A  A 

ic    /i   pt   i\   pa  Trt   i on 
1  r    ( J  .  b 1  . 1 )   bU    1 U  190 

A  1  A  1  A  C  A 

rLU1450 

VI      V  /  V  1  \ 

Y 1=X (K3 ) 

D  1  A  T  A  L  A 

V  A  VI 

Y  U=Y  1 

rLU1470 

IS  1=1 

Dl  A 1  VI  O  A 

1  O  A 

190 

PA     TA      /  1  A  A     O  O  A  \  l/rv 

bU    IU    (200,220),  KtY 

A  1    A  1  >l  A  A 

PLU1490 

O  A  A 

nn  11  n  t  i/  i  i/» 
UU   ZJ.0    1=N3 , l\4 

D  1  A  1  C  A  A 

r LU1500 

TC     /VI     IT    V/T\\     VI  V/T\ 

lr    (Yl.LI.X(l))  Y1=X(1) 

D  1  A  1  C  1  A 

KLU1510 

TC      /VA     PT    V/T\\     VA  V/T\ 

lr    (YO.bl.X(l))  Y0=X(1) 

D 1  fll  C1A 

rLUlDZO 

<:  1 0 

r  amt  t  aji  ic 

di  ni  ciA 
rLUi.D3U 

p/l    ta  i/n 
bU    IU  260 

D i ni c/n 
r LU1540 

liv 

DO  250  I=K3,K4 

D  I   (11  CCA 

rLUlbDO 

IF  (X(K1) .GE.XAN.AND.X(Kl) .LE.XAP)  GO  TO  (230,240),  KY 

D  1  A  1  C  L  A 

KLU1560 

GO  TO  250 

D 1  A  1  C  7  A 

rLUlb  7  0 

230 

Y1=X(I) 

di  a 1  C Q A 

Y0=X(I) 

D  1  ftl  cflrt 

rLU1590 

KY=2 

D 1  A  1  L  A  A 

HLU1600 

GO  TO  250 

DI  (IKlfl 
r LU1 0 IU 

1  il  A 

240 

IF  (Yl.LT.X(I))  Y1=X(I) 

di  m  iin 

IF  (YO.GT.X(I))  Y0=X(I) 

DI  di  tin 
rLU103U 

250 

K1=K1+1 

D  1  A  1  L  A  A 

r LU1640 

260 

CONTINUE 

D  1  (11  /  CA 

HLU1650 

YAP=Y1 

D  1   (11  ii  A 

PLUlobO 

YAN=Y0 

D 1  n  1  L  7  A 

IF  (ISWT.EQ.l)  GO  TO  800 

di  ai  ton 

GO  TO  280 

Dim  AO  n 
r LU107U 

270 

Y1=YUP 

D 1  A  1  7  A  A 

rLUl/00 

Y0=YD0WN 

D 1  A  1  7  1  A 

KLU1710 

ISWT1=1 

D  1  A  1  7  O  A 

rLUl  7  i\i 

IF  (ISWT.EQ.2)  GO  TO  770 

D  1  A  1  7  1  A 

HLU1730 

280 

X1=XUP 

D  1  A  1  7  A  A 

KLU1740 

X0=XD0WN 

D 1  A  1  7  C  A 

HLU1750 

GO  TO  770 

D 1  A  1  7  L  A 

KLU1760 

C 

DETERMINE  X  AND  Y  INCREMENTS 

FOR  PLOT 

PL01770 

240 


290 

YDELTA= (YMAX-YMIN ) /50 . 

PL01780 

K1=IARGS (NARGS) 

PL01790 

XDELTA=(XMAX-XMIN) /FLOAT (IPT) 

PL01800 

YL=YMAX-YDELTA/2 . 

PL01810 

YT=YMAX 

PL01820 

IF  (ISWT.LE.l)  GO  TO  820 

PL01830 

IF  (L2.EQ.6)  GO  TO  300 

PL01840 

WRITE  (IPRINT,1050)  NTOT ,NCN 

PL01850 

GO  TO  820 

PL01860 

300 

WRITE  (IPRINT,940)  NTOT ,NCN 

PL01870 

GO  TO  820 

PL01880 

310 

KYTL=1 

PL01890 

IF  (YMAX.LT.YMIN)  KYTL=2 

PL01900 

KXTL=1 

PL01910 

IF  (XMAX.LT.XMIN)  KXTL=2 

PL01920 

ITB=1 

PL01930 

C 

THE  I  LOOP  CONTROLS  THE  5  DIVISIONS  OF  THE  Y  ORDINATE 

PL01940 

DO  620  1=1,6 

PL01950 

L=l 

PL01960 

C 

THE  J  LOOP  IS  FOR  EACH  LINE  OF  PRINT  WITHIN  THE  DIVISIONS 

PL01970 

DO  620  J=l,10 

PL01980 

C 

BLANK  OUT  PRINT  BUFFER  LINE. 

PL01990 

DO  320  K=1,IPTX 

PL02000 

320 

PRINT (K)=BLANK 

PL02010 

C 

THE  KK  INDEX  IS  FOR  EACH  CURVE.     KK  LESS  THAN  6. 

PL02020 

DO  500  KK=1,M 

PL02030 

K3=IARGS (KK) 

PL02040 

K4=K3-1+NRMAX 

PL02050 

K5=K1 

PL02060 

C 

THIS  DETERMINES  IF  Y(K)  VALUE  IS  ON  THE  PRESENT  PRINT  LINE 

PL02070 

DO  490  K=K3,K4 

PL02080 

GO  TO  (330,350) ,  KYTL 

PL02090 

330 

IF  (X(K)-YT)  340,340,490 

PL02100 

340 

IF  (X(K)-YL)  490,490,370 

PL02110 

350 

IF   (X(K)-YL)  360,360,490 

PL02120 

360 

IF   (X(K)-YT)  490,490,370 

PL02130 

C 

YES.  Y(K)  BELONGS  ON  THIS  PRINT  LINE 

PL02140 

C 

THEREFORE  DETERMIND    WHERE  ALL  THE  X(K5)  FALL  ON  THE  X-AXIS 

PL02150 

370 

XL=XMIN 

PL02160 

XT=XMIN+XDELTA/2. 

PL02170 

DO  480  KA=1,IPTX 

PL02180 

GO  TO  (400,380) ,  KXTL 

PL02190 

380 

IF  (X(K5)-XT)  470,470,390 

PL02200 

390 

IF   (X(K5)-XL)  420,420,470 

PL02210 

400 

IF   (X(K5)-XL)  470,410,410 

PL02220 

410 

IF   (X(K5)-XT)  420,470,470 

PL02230 

420 

IF  (PRINT (KA) -BLANK)  440,430,440 

PL02240 

430 

PRINT (KA)=BOOL (KK) 

PL02250 

GO  TO  490 

PL02260 

C 

IF  MORE  THEN  ONE  POINT  FALLS  ON  THE  PRINT  POSITION,  TALLY  THE  NO. 

PL02270 

C 

OF  POINTS. 

PL02280 

440 

DO  450  KKK=1,9 

PL02290 

IF  (PRINT (KA)-IDGT (KKK) )  450,460,450 

PL02300 

450 

CONTINUE 

PL02310 

PRINT(KA)=IDGT(1) 

PL02320 

GO  TO  490 

PL02330 

460 

IF  (PRINT(KA)  .NE.IDGT(9))  PRINT (KA)  =  IDGT (KKK+1) 

PL02340 

GO  TO  490 

PL02350 

470 

XL=XT 

PL02360 
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/!  0  ft 

VT_YT  .  vnCI  TA 
A  1 =A 1 +AUCL  1  A 

D 1  ft  O  1  7  A 

Y\-XiL5  1 0 

^QA 

K3=K3+i 

di  no 7 0 a 
rLU^ JoO 

3UU 

rnMT  T  Ml  IP 

D  1  n  0  "2  Q  A 

r LUt J7O 

VD— VT*VI 

p  1  n  0  a  ft  ft 
r  LUZ'JUO 

VT—VI 
1  1  =1  L 

pi  n 0  a  i  ft 
r LUZh 1 0 

VI  —VI     VRPI  TA 

pi  n 0  a  0 ft 
rLU^HZO 

fin  to  /ei  n  ccn\  1 

di  no ^  7 ft 
r LUZ4 i 0 

ci  n 
D1U 

tp   /  t  c \  con  con  A^n 

PI  no  A  A  ft 

J  c  u 

1  — ? 

PI  n?4c.ft 

V^— VTj.YnPI  TA  10 
I J=l 1+TUtLIH/i . 

pi  n  0  A  A  ft 
r LUtf OU 

u 

TUTC.    PATH    TC    FYFPIITFn,    nWTF    TW    FV/FPV    nTVTCTnM   OF    TUP    V    AYTC  FUFDV 
Inlo    rHIn    1  j    CALOUItU    UHLt    IN    tvtKY    U1V1 31UN    Ur     1  tit    Y—  MAI  J  .  tVtKT 

D  1  ft  0  /!  7  ft 

r LUZ4 / 0 

u 

TFNTH   1  TNF      C.TARTTNfi   WITH   7FR0,   1  TNF 
1  t Ii  1  n    L  l  vt  C  ,    j  1  Ai\  1  INu    nl  In    L  t  !\  U    L  1 1  x  C 

DI  nOAflft 
rLUtHOU 

TF    M  0    pn    A\    fin   TO  C7ft 
ir    (  l i  .  cy . 0 )   uu   1 u  j / u 

pi  no/ion 

TF    (YP\    l^ft    C^n  14(1 

pi  no enn 

r  LU  L3UU 

c.  n 

UIRTTF    MPRTNT    QAft\    TIT/TTRl    VC  PRTNT 
ni\  1  1  t    (lrKlNI,70UJ     111(1101,13  ,rnin  1 

di  no c i  n 

r  LU  4  D 1 U 

fin   TO  A9ft 

pi  no  c 0 n 

r LUt  3 1 U 

UIRTTF    MPRTWT    Q  eft  \    TTT/ITRl    VC  PRTWT 
ni\  1  1 1    (lrKini  ,73U)  iii^iDj(io(ri\irii 

di  n 0 c  1  ft 

rift    TO  AOft 

di  no c/in 

J  jU 

TF    li  0   Ffi  A\   fin  TH  con 

1  r      (  L  L  .  t  w,  .  0  J    UU     IU    J  ;U 

di  no ccn 

rLUt33U 

TF    /VP\    CAft    CAft  Alft 
lr     (  I  r  )     30U  ,  DOU , 01U 

DI  no  c.  Aft 
r LUtDOU 

r 

w 

PR  T  NT*;   1  TNF 

r  K  1  N  1  3  LlliC 

pi  no E.7 n 

r  LU L 3 / U 

1;  Aft 

UIRTTF    MPRTNT    Q7ft\    TTT/TTR\  PRTWT 

hk  i  1 1   ■irKiNi,7/uj    111  (iiDj  ,rninii 

pi  n 0 c 0 a 

fin   TO  A0ft 
uu   1  u  0  i.  u 

pi  no  con 

rLUi37U 

570 

TFiYP  fiT  fi           CO  TO  ^Rft 
ir^ir.ui  .u.uj      uu    iu  jou 

pi  n?Ann 

WRTTF    MPRTNT   QQft \    TIT/TTR\    V<    /PRTNT/IO    K  —  T    T PTY \ 
nl\l  1  L    (irnini  ,  "BU)     1  1  1  \  1  1  D  )  ,  I  3  ,  \  r  n  1 l»  1  ■  l\  )  ,  r\=l  ,  IrlAJ 

pi  no  A  T  ft 

Cfl  TO  A?fl 
uu    1  u  0  *. u 

pi  n? a? n 

CRft 

UIRTTF    (TPRTWT    OQft\    TTTMTBl    VC    /DR1WT      \  TPTY\ 
■  Kilt     (  1  rl\lN  1  ,  77U  J     I1I(1ID),!3,  (rl\iw  1          ,  l\=i  ,  lr  1  A] 

pi  no  a  7  ft 

fit)    Tft  A5ft 
UU    1 U    0  £  u 

pi  no  A/in 

r LUtOHU 

K,>3),n 

TP/VP  fiT  n  n\    fin  to  Ann 
ir^ir.ui.u.uj     uu   iu  ouu 

pi  n?Acn 

r  lu  cOju 

UIRTTF    iTPRTNT    lnnni    TTTiTTR\     !PRTNT^K^    k  — T    T  PTY  ^ 
nrvllll     (  lrRlll  1  ,  1UUU  )     lll^llDJ^rnini^j,  l\=  1  ,  lr  1  A] 

pi  n  0  a  Aft 

fin  Tn  A?n 

UU     IU    0  L U 

pi  n?A7n 

|LU£Q 1 U 

Aftft 

ouu 

UIRTTF    /TPRTWT    1  ftl  ft  \    TITMTRi     /PRTWT/I^\    Y  —  1  TPTY\ 
WR1  1  t    (IrnlNI  ,1U1UJ     111  >llDj  ,  ^rl\lWI  V">-  /  /  i^=-L  ,  lr  1  A) 

pi  noASft 

cn  Tn  Aon 

UU     1  U  OC\J 

PI  noAQft 

r  lu  c 0  7  u 

A  1  ft 

UIRTTF    MPRTNT    lftoftx    TTTMTR\  PRTNT 
■i\i  1 1   iirr\iroi,iU£U/  iii(iiu),ri\iiii 

PI  n97ftft 

nut  /  uu 

T  TR— TTRj.1 

1 1 D — 1 1 Dtl 

pi n?7T  n 

tf  n  0  pn  a\  r;n  Tn  am 

lr     (Li.Ly.o;    UU    IU  7lU 

pi  no7on 

r LUi/ £  U 

TF    tVP\    AAft    AAft  A^ft 
lr     (Ir ]    OHU , 01U , 03U 

pi  fi?7,?n 

rLUt  /  j\J 

UIPTTF    MPRTWT    QAft\    T  T  T  /  C 1  \    VMTW  PRTWT 
nr\  lit    (IrKlNI  ,70U)  ll'l\31/fTMlH(rKlNI 

pi  no 7/ift 

r LUi 1 HU 

fin    Tfl  AAft 
UU    1 U  OOU 

pi  n57cn 

r LU£ t  3U 

UIRTTF    /TPRTWT    ocn\    TTTici  \    VMTW  PRTWT 
nl\  1IC    (  1  rl\  1  n  1  ,  73U  )     1  1  1  \  3 1 )  ,  T  IH1N  ,  rn  in  1 

PI  n?7Aft 
r lul / ou 

U 

1  A^T  1  TNF  nF  PRTNT  fit  IT  PI  IK  Y  V/AI  IIF<;  Al  nNfi  Y.  AY!5; 

LAj  1     Llriu    Ur     rffxlli!     UUI     rLUj    A    VHLUtJ    MLUI»U    A-nAi  J  . 

pi  00770 

rLUti / U 

A  Aft 
OOU 

UIRTTF    /TPRTNT    IftAftl  TPR 
Wr\  1IC     (  1  r  Kill  1  ,  1UCU  j  IrK 

pi  n?7Rn 

rLUt / OU 

UIRTTF    /TPRTWT    lftim  YP 
BK  1IL    ( IrK  in  i  ,  l\i  JV  )  Ar 

pi n?79n 

r  lu  c 1 7  u 

UfDTTP     /TPDTMT    1ft7ft\  TTTY 
WK  lit    (  1 rKin 1  ,  IU / U )     1  1  1  A 

PI  OORftft 

r  LUYOUU 

DPTIIRW 
Kt  1  UKIM 

pi  nop. i n 
rLUtoiu 

L> 

Till  C    PRTWTC    nilT   TUAT    'V    RftllWnC    ARF    WflT    CFT    IIP   mRRFfTI  V' 
Inlo   rKllMlo   UUI     1  HA  1       T    DUUNUj   AKt   NU  1    3t  1    Ur  uUKKtuILT 

pi  n?ft?ft 

0  /  U 

PftWT  T  Ml  IP 
uUN 1 1 Nut 

pi  n?R^n 

r LUi  0  J  U 

p 

O 

TUTC    DOTMTC    nilT   TUAT    '  Y    RHIIWRC    ARF    Wf\T    CFT   IIP   mPRFfTI  V' 
IHli   rKlSMIo   UUI     1  HA  1      a   DUUIMUj   AKt   NU  1    Dtl    Ur   UUKKtu  1  L  T 

pi  n?fldn 

/OA 

00U 

rt\ WT  T  Ml  IP 
tUN 1 1 NUt 

pi  noRcn 
r  LUi  0  3  u 

TUTQ   PRTNT    Tfll       WnQ      APPPAR   A^   ARfillMFNT^ ' 
1  nl  j  rKin  1     uul.   NU3  .   ArrtMK  mo  mkuu  wst  n  i  j 

pi n?RAn 

Aon 

r  A 1  1     PRPftR    /  0  ft  \ 
OALL  tKKUK 

pi n?R7n 

7  A  ft 

/  00 

MPPPftD    MPOOftD  1 
NtKKUK=N tKKUK— 1 

pi  n? RRO 
r LUi  0  ou 

DCTI IDM 

Kt 1 UKN 

pi  n?Ron 

r LUi  0 7  U 

L 

TUTC    DOTMTC    TUAT    'UftDF    TUPM    C    PI  ftTC    IMF  DP    DFftllTCTPn    PFR    COADU  ' 

Inib  rKlNIb    1  HA  1      MUKt    1 HtN  3   rLUlo  WtKt  KtyUlo 1 tu  rtK  uKArH 

pi  noonn 

r LUi 7UU 

7  1  A 

710 

LALL  tKKUK  (10) 

pi  nooi n 

r LUi 7 xu 

Aft    Tft     7  A  ft 

bU    1 U   / 00 

PI  n?Q7f) 
r  lu  c 7 c u 

7  0ft 
/iO 

Kt  1=1 

PI  n?Q3ft 

DO  760  IK=1(M 
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730 


740 

750 
760 


770 


780 
790 

C 

800 


810 
820 

830 
840 
850 


860 

870 

880 
890 


DO  750  I=K1,K2 

IF   (X(IKK) .GE.YAN.AND.X(IKK) .LE.YAP)  GO  TO   (730,740),  KEY 

GO  TO  750 

X1=X(I) 

X0=X1 

KEY=2 

GO  TO  750 

IF   (Xl.LT.X(I))  X1=X(I) 
IF  (XO.GT.X(I))  XO=X(I) 
IKK=IKK+1 
CONTINUE 

IF  (KEY.EQ.2)  GO  TO  140 

XO=XDOWN 

X1=XUP 

GO  TO  140 

DO  790  J=1,M 

K1=IARGS (NARGS ) 

K3=IARGS(J) 

K4=K3-1+NRMAX 

DO  790  I=K3,K4 

IF  (X(I) .GT.YAP.OR.X(I) .LT.YAN)  GO  TO  780 
IF  (X(K1) .LE.XAP.AND.X(Kl) .GE.XAN)  GO  TO  790 
NCN=NCN+1 
K1=K1+1 

NTOT=M*NRMAX-NCN 

DETERMINE  TYPE  OF  HEADINGS  TO  BE  PRINTED 

CALL  HEADS  (KCCL  , NARGS , 0 , 1 ) 

K=4 

IF  (L2.EQ.6)  K=l 

CALL  PAGE  (K) 

IF  (L2.EQ.6)  GO  TO  810 

WRITE  (IPRINT.1040)    ( IH ( I , NARGS ) , 1=1 , 12 ) , ( ( IH ( I , J ) , 1=1 , 12 
L,J=1,M) 
GO  TO  290 

WRITE  (IPRINT,1080)   ( IH ( I , NARGS ) , 1=1 , 12 ) , ( ( IH ( I , J ) , 1=1 , 12 ; 
L,J=1,M) 
GO  TO  290 
XP(1)=XMIN 
XP(6)=XMAX 
XR=20.*XDELTA 
DO  830  1=2,5 
XP(I)=XP(I-1)+XR 
DO  840  J=l,100 
IPR(J)=B00L(5) 
DO  850  1=1,101,10 
IPR(I)=B00L(3) 

IF  (XMIN*XMAX.GE.0.0)  GO  TO  900 
J=0 

DO  860  1=2,5 

IF  (XP(I-1)*XP(I))  870,890,860 

CONTINUE 

N=IPTX 

GO  TO  890 

XXP=XP(I-1)+XDELTA 
DO  880  J=l,20 

IF  (XP(I-1)*XXP.LE.0.0)  GO  TO  890 

XXP=XXP+XDELTA 

J=20 

N=(I-2)*20+J 


PL02960 
PL02970 
PL02980 
PL02990 
PL03000 
PL03010 
PL03020 
PL03030 
PL03040 
PL03050 
PL03060 
PL03070 
PL03080 
PL03090 
PL03100 
PL03110 
PL03120 
PL03130 
PL03140 
PL03150 
PL03160 
PL03170 
PL03180 
PL03190 
PL03200 
PL03210 
PL03220 
PL03230 
PL03240 
PL03250 
PL03260 

,B00L(J)PL03270 
PL03280 
PL03290 

,B00L(J)PL03300 
PL03310 
PL03320 
PL03330 
PL03340 
PL03350 
PL03360 
PL03370 
PL03380 
PL03390 
PL03400 
PL03410 
PL03420 
PL03430 
PL03440 
PL03450 
PL03460 
PL03470 
PL03480 
PL03490 
PL03500 
PL03510 
PL03520 
PL03530 
PL03540 
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T  DP  ^  M \  —  T YDD 

D 1  n  i  c  c  a 

AAA 

900 

UfDTTP     (  IDD  I  MT    1A£A\      i10DlV\    V     1     T  DTY  \ 
WKJ.lt    (  IrKIN  1  ,  lUOU  )     (  1  rK  (K )  ,  N=l  ,  lr  1  A) 

d i Aac/n 
PLU3560 

r  n  Tft  ji  n 

d i nacirt 
rLUiD/O 

7lU 

iriir.ul  ,U,U)      bU    1  U   7  <:  U 

D i nicon 

UID  TTC     /  IDDIkIT    O  Q  A  \    TIT  (CI  \    VMTKI     /  DD  T  KIT  f  IM 
WKiiL    (lrl\lNI,9ol))  lll(3l),YMlN,(rKlNI(K) 

V    1     T DTY \ 

r LU3590 

rn  Tn  q in 

bU    1 U   7  i U 

D 1  n  i  l  a  a 
r LUioOO 

UIPTTF    MPD1MT    QQO\    TIT/R1  \    VMTM  /DDIWT(k\ 
WKl  It    (IrKlQ  1  (77U  J     1  1  1             ,YIVIlPf,  \ 

tf  —  l     T  DTY \ 
,  1^=1  ,  1  r  1  A  ) 

d i niiin 
rLKJi  oil) 

U/RTTF     (IDDTMT    10AO\     lfDQ(W\    V    1     T  DTY  \ 

d  i  n  i  l  o  a, 

U/DTTF    /  IOPTMT    i  nin\     tYD  lit  \    V    1  AN 
nt\  1  I  t    ^  1  r  K  i  IM  I  ,  1  U.5  U  )    ^  Ar  ^  Fk ;  ,  1^=1  , 1 ) 

d  i  n  "x  l  i  a 

U/DTTF     <  IDRIMT    10QO\  TTTY 
nrv  1  I  C    ^  i  r  K  1 N  I  ,  1U7U  )  I1IA 

r  LU.J  041) 

DFTIIDM 
Kt  1  UKIM 

r  HJ3650 

d  i  c\  1  L  L  A 

rLUiooO 

Q  AO. 

FORMAT  (21H  NO.  OF  PTS .  PLOTTED  ,15 ,33H  NO.  NOT  PLOTTED 

IUUI    Ur  DUrLUJO/U 

1UNDS)  ,15) 

d i  ni£.Qn 

ncn 
7jU 

FORMAT  (1X,A1,1PE11.4,1H+,101A1,1H+) 

D  1  (\  1  L  Q  A 

rLU^07U 

O  L  A 
701) 

FORMAT  (1X,A1,1PE11.4,1HX,101A1,1HX) 

D  l  n  "2  7  A  A 

rLL)3  7  00 

7  /  U 

FORMAT  (1X,A1,11X,1HX,101A1,1HX) 

d  i  n  7  7 1  a 

ngn 
70U 

FORMAT  (IX, Al, 1PE11 .4, 1HX.61A1 ,1HX) 

D  1  n  "3  7  ^  A 

nnn 

77U 

FORMAT   (1X,A1,1PE11 .4,1H+,61A1 ,1H+) 

D  1  H  1  7  1  A 

i  u  u  u 

FORMAT  (1X,A1,11X,1HX,61A1,1HX) 

D  1  n  *3  7  ^  A 

YV.\)i  /  41) 

i  ni  n 

1  U  1  u 

FORMAT  (1X,A1,11X,1H-,61A1,1H-) 

rL\)i  I  Dl) 

1  111  "1  ft 
i  U  si  u 

FORMAT  (1X,A1,11X,1H-,101A1,1H-) 

d  i  n  *a  7  z.  a 
rLU3 / 60 

i  n?n 

FORMAT  (6(7X,1PE13.4)  ) 

D  I  n  7  7  7  A 

rLU^ / / U 

1  OAfi 
J.U'HI 

FORMAT  (6H  ABS-  , 12A1 , 6H , ORD-  ,5(12A1,2H 

(,A1,3H),  )) 

d i ni7on 
rLU^ / oU 

i  nco 

1UDU 

FORMAT  (29H  TOTAL  NO.  OF  PTS.  PLOTTED  IS, 

I5,60H  AND  NO. 

WDT  Di  nTTFDl  ni7on 
nu I    rLU 1 ICrLUi/7U 

ID    BECAUSE  THEY  FALL  OUTSIDE  OF  BOUNDS  IS, 15) 

D 1  n  7  Q  A  A 

i  nin 

FORMAT  (14X,101A1) 

D 1  n  1 0  i  a 
r  LU  Jo  J.U 

1  0,70, 

FORMAT  (34X,60A1) 

r  Lu J  0  c U 

'tf  Iff  p  fii 

FORMAT  (6H  ABS-  ,12A1/6H  ORD-  ,5(12A1,2H 

(,A1,3H),  )) 

d  1  n  1 0 1  a 

1  A  A  A 

1090 

FORMAT  (14X,60A1) 

PLU3840 
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c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 


SUBROUTINE  PREPAK  (N , IND , IA , LOC , LH) 
VERSION     5.00  PREPAK  5/15/70 


C 

c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 

c 
c 
c 
c 
c 
c 

c 
c 
c 
c 
c 
c 
c 


s 

THIS 

N=l 

N=2 


N=3 
N=4 
N=5 
IND 


PEAVY  8/  5/69 

SUBROUTINE  DOES  THE  FOLLOWING : 
PACK  FORMAT    IN  IFMT 

PACK  HEAD        IN  IHEAD.  IF  MORE  THAN  50  HEADINGS  ARE  STORED, 
STACK  OF  HEADINGS  IS  PUSHED  DOWN  AND  BOTTOM  ONES 
DISCARDED 

CLEAR  VARIABLES    IFMT  AND  IHEAD 

PICK    UP    PROPER    FORMAT    NO.  IN  IA  AND  STORE  IN  LH 
UNPACKS    THE  HEADING  OF  LOC.  INTO    LH  IA  Al  LEFT  JUSTIFIED 
INDICATOR.  IF  IND  =0  CALL  TO  PREPAK  WAS  O.K. 

IF  IND  =1  A  FLAG  THAT  RESULTS  WERE  NOT  OBTAINED 


PRE 
PRE 
PRE 
PRE 
PRE 
PRE 
PRE 
PRE 
PRE 


10 
20 
30 
40 
50 
60 
70 
80 
90 


IA      COL  NUMBER  FOR  THE  HEADING  TO  BE  PACKED  OR  FORMAT  DESIRED 

LOC    LOC  CONTAINS  THE  COLUMN  NUMBER  WHOSE  HEADING  THE  SUBROUTINE 
IS  TRYING  TO  FIND. 

LH      IS  WHERE  THE  HEADING  WILL  BE  STORED  AS    Al  LEFT  JUSTIFIED 
AFTER  IT  IS  UNPACKED,  IF  THE  TITLE  IS  FOUND. 
OR 

WHERE  FORMAT  WILL  BE  STORED  IF  N=4 
COMMON  /ABCDEF/  L(48) 

COMMON  /BLOCKA/  MODE , M, KARD (83 ) , KARG , ARG , ARG2 , NEWCD (80 ) , KRDEND 
COMMON  /PKSWT/  IHCNT,IHTP 

COMMON  /BLOCKC/  KIO , INUNIT , ISCRAT , KBDOUT , KRDKNT , LLI ST 
COMMON  /SCRAT/  NS  ,NS2 , A  (13500 ) 
DIMENSION  IAA(80) 
EQUIVALENCE  (A , I AA) 
DIMENSION  LH(1) 


PRE  100 
PRE  110 
PRE  120 
PRE  130 
PRE  140 
PRE  150 
PRE  160 
PRE  170 
PRE  180 
PRE  190 
PRE  200 
PRE  210 
PRE  220 
PRE  230 
PRE  240 
PRE  250 
PRE  260 
PRE  270 
PRE  280 
PRE  290 
PRE  300 
PRE  310 


PRE  330 

THE  VARIABLE  IFMT  CONTAINS  THE  INFORMATION  FOR    6  FORMATS  PRE  340 

(I  E.     FORMAT  A  THUR  F) .     THE  MAXIMUM  LENGTH  FOR  EACH  FORMAT  IS      PRE  350 

72  CHARACTERS  INCLUDING  LEFT  AND  RIGHT  PARENTASIS .  IF  FORMATS  ARE  PRE  360 

PACKED  DIFFERENTLY  THEN  STATED  BELOW  ,  THE  DIMENSION  SIZE  OF  PRE  370 

THE  FIRST  (12)     CONSTANT  MUST  BE  CHANGED    TO  BE  EQUAL  OR  GREATER    PRE  380 

THAN  72/ (NO.  OF  CHARACTERS  PER  WORD)+M.  SEE  NOTE  BELOW  FOR  M  VALUEPRE  390 

CAUTION :  FORMATS  MUST  BE  PACKED  IF  NH  CONVERSION  IS  PERMITTED         PRE  400 

PRE  410 

PRE  420 

PRE  430 

PRE  440 

PRE  450 

PRE  460 

I FMT ( 1 1 , 6 ) , I  HEAD ( 5 , LA  ARE  REDIMENSIONED  SO  THAT  PRE  470 


THE  VARIABLE  IHEAD  (5, LA)  CONTAINS  THE  HEADINGS  FOR  LA  COLUMNS 
MAXIMUN  NO.  OF  CHARACTERS    PER  HEADING  IS  12. 

DIMENSION  IFMT(12,6),  IHEAD(5,50) 


IF  THE  VARIABLES 


II  DOES  NOT  =  12 
AND    LA  DOES  NOT  =  50 

THEN  THE  FOLLOWING  DATA  STATEMENT  MUST  BE  CHANGED 
DATA  11/12/, LA/50/ 


PRE  480 
PRE  490 
PRE  500 
PRE  510 
PRE  520 
PRE  530 

FORMAT  90  MUST  BE  CHANGED  IF  MORE  OR  FEWER  CHARACTERS  CAN  BE  PRE  540 

PACKED  INTO  A  WORD.  90  FORMAT  (IIAK)  WHERE  II  IS  DEFINED  ABOVE  ANDPRE  550 
K  =12/ (CHARACTERS  PER  WORD)+M.  PRE  560 

WHERE    M=0  IF  12/ (NO.  OF  CHAR/WORD)  HAS  NO  REMAINDER  PRE  570 

AND        M=l    IF  12/ (NO.  OF  CHAR/WORD)     HAD  A  REMAINDER  PRE  580 

*************************************************************  £<JQ 
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STORES  FORMAT 


IF  (N.GT.5)  GO  TO  60 
INO=0 

GO  TO  (10,70,150,180,200)  ,  N 
C         THIS  PART  OF  PROGRAM  PACKS  AND 
10        K=KARD (M) 
15  M=M+1 

IF  (KARD(M) .NE.41)   IF   (KARD (M) -46 )  15,60,15 

KK=1 

KA=0 

MA=M+1 

KR=KRDEND+3 

DO  20  I=MA ,KR 

IF  (KARD (I)  .EQ.41)  KK=KK+1 
IF  (KARD ( I )  .NE.42)  GO  TO  20 
KA=KA+1 

IF  (KA.EQ.KK)  GO  TO  30 
20  CONTINUE 

GO  TO  60 
30  MB=M-2 

IM=I-M+1 

DO  40  JA=1,80 
40  IAA(JA)=L(45) 

DO  50  JA=1,IM 

IAA(JA)=NEWCD(MB) 
50  MB=MB+1 

WRITE  (ISCRAT,240) 

BACKSPACE  ISCRAT 

READ  (ISCRAT, 230) 

BACKSPACE  ISCRAT 

RETURN 
60  IND=IND+1 

RETURN 
C         THIS  PACKS  HEADS 
70        IF  (IHCNT.GE.IHTP)  GO  TO  140 

IF  (IHCNT.EQ.O)  GO  TO  110 
C         IHEAD(1,I)=C0L  NUMBER  FOR  THAT  HEADING 

DO  80  I=1,IHCNT 

IF  (IA.EQ.IHEAD(1,I) )  GO  TO  130 
80  CONTINUE 

KB=IHCNT 
90        DO  100  I=1,KB 

KA=KB-I+2 

DO  100  K=l,5 
100      I  HEAD (K,KA)  =  IHEAD (K ,KA-1 ) 
110  IHCNT=IHCNT+1 
120  IHEAD(1,1)=IA 

ICHAR=12 

DO  122  1=2,5 

C         THE  FOLLOWING  CONSTANT  IS  (45*256+45 ) *256+45 

122      IHEAD   (I ,1)=2960685 

IF(M+12 .GT.KRDEND+3)  ICHAR=KRDEND+2-M 
CALL  PACK (KARD (M+l ) , IHEAD (2 , 1 ) , I CHAR ,0 ) 
RETURN 

130      IF  (I.EQ.l)  GO  TO  120 
KB=I-1 


(IAA(JA) ,JA=1,80) 
(IFMT(JA,K-9) ,JA=1,II) 


140 


GO  TO  90 
KB=IHTP-1 
CALL  ERROR 
GO  TO  90 
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PRE  980 
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PRE1044 
PRE1046 
PRE1050 
PRE1052 
PRE1054 
PRE1060 
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PRE1105 
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c 

N=3      CLEAR  IFMT ,  IHEAO 

PRE1120 

150 

DO  160  1=1,6 

PRE1130 

DO  160  I A=l , 1 1 

PRE1140 

160 

IFMT(IA,I)=0 

PRE1150 

DO  170  1=1, LA 

PRE1160 

DO  170  IA=1,5 

PRE1170 

170 

IHEAO (IA , I )=0 

PRE1180 

RETURN 

PRE1190 

C 

FIND  PROPER  FORMAT 

PRE1200 

180 

IF  (IA.LT.2.0R.IA.GT.7)     GO  TO  60 

PRE1210 

IF  (IFMT(1,IA-1) .EQ.O)  GO  TO  60 

PRE1220 

DO  190  1=1,11 

PRE1230 

190 

LH(I)=IFMT(I ,IA-1) 

PRE1240 

RETURN 

PRE1250 

C 

SEARCH  FOR  HEADING  AND  UNPACK 

PRE1260 

C 

IF  HEADING  IS  FOUND  IND=0,  OTHERWISE  1. 

PRE1270 

200 

DO  210  I=1,IHCNT 

PRE1280 

IF  (L0C.EQ.IHEAD(1,I) )  GO  TO  220 

PRE1290 

210 

CONTINUE 

PRE1300 

C 

NO  HEADING  FOUND 

PRE1310 

GO  TO  60 

PRE1320 

220 

CALL  PACK  (IHEAD(2,I)  ,LH,12,1) 

PRE1330 

RETURN 

PRE1340 

C 

PRE1350 

230 

FORMAT  (12A6) 

PRE1360 

240 

FORMAT  (80A1) 

PRE1370 

END 

PRE1380 
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SUBROUTINE  PRINTX  PRI  10 

VERSION     5.00          PRINTX          5/15/70  PRI  20 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG  PRI  30 

COMMON  /BLOCRC/  NRC  , RC  ( 12600 )  PRI  40 

COMMON  /BLOCKD /  IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NPRI  50 

1ARGS ,VWXYZ (8 ) ,NERROR  PRI  60 

DIMENSION  ARGS(IOO)  PRI  70 

EQUIVALENCE  ( ARGS ( 1 ), RC ( 12501 ) )  PRI  80 

COMMON  /HEADER/  NOCARD  (80) ,  ITLE (60 , 6 ) , LNCNT , I  PR  I  NT ,NPAGE , I  PUNCH  PRI  90 
COMMON  /FMAT /  IFMTX (6) , IOSWT , IFMTS (6) ,LHEAD (96) 
COMMON  /KFMT /  KFMT(IOO) 


THIS  SUBROUTINE  IS  CALLED  TO  EXECUTE  THE  FOLLOWING 

PRINT  //  COLS  ++,++, ++,++(ETC     (PRINT  WITH  FORMAT//) 
PRINT      COLS  ++,++,++,++      USE  RPRINT  IF  ALL  ARGS  ARE 

UNLESS  IOSWT  IS  ON 
PRINT     (USING  ARGS  AS  IN  RPRINT)  ALWAYS  USE  RPRINT 

Ll=2  PRINT 
Ll=8  NPRINT 

IF  (NARGS.NE.O)  GO  TO  45 
CALL  ERR0R(205) 
RETURN 

CALL  ERROR  (222) 

IF  (NPAGE.EQ.O   . AND . LI . EQ . 8 )  CALL  PAGE(O) 

CALL  RPRINT 

RETURN 

IF  (L2.EQ.1)  IF  (IOSWT)  40,40,230 
CALL  PREPAK  (4 , IND ,L2 , IND ,KFMT) 
IF  (IND.NE.O)  GO  TO  30 
IP=1 

CALL  CHKCOL  (I) 

IF  (I.NE.O)  GO  TO  10 

IF  (NERROR . NE . 0 )  RETURN 

IB=0 

IA=1 

ICP=0 

GO  TO  (60,70) ,  IP 
IB=NARGS 
GO  TO  100 
IBB=NARGS 

IF  (IBB.GT.8)  GO  TO  90 

IB=IBB+IB 

IC=IBB 

IBB=0 

GO  TO  100 

IBB=IBB-8 

IB=8+IB 

IC=8 

LL=NRMAX 

IF  (LL.GT.51)  GO  TO  120 

J=LL 

LL=0 

GO  TO  130 

LL=LL-50 

J=50 

IF  (L1.EQ.8)  IF (NPAGE)  155,260,155 

CALL  PAGE  (4) 

GO  TO  (150,140) ,  IP 


INTEGER 


PRI  100 

PRI  110 

PRI  120 

PRI  130 

PRI  140 

PRI  150 

PRI  160 

PRI  170 

PRI  180 

PRI  183 

PRI  187 

PRI  190 

PRI  200 

PRI  210 

PRI  220 

PRI  225 

PRI  230 

PRI  240 

PRI  249 

PRI  250 

PRI  260 

PRI  270 

PRI  280 

PRI  290 

PRI  300 

PRI  305 

PRI  310 

PRI  320 

PRI  330 

PRI  340 

PRI  350 

PRI  360 

PRI  370 

PRI  380 

PRI  390 

PRI  400 

PRI  410 

PRI  420 

PRI  430 

PRI  440 

PRI  450 

PRI  460 

PRI  470 

PRI  480 

PRI  490 

PRI  500 

PRI  510 

PRI  520 

PRI  530 

PRI  540 
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140      CALL  HEADS  (KFMT (IA) , IC , ICP ,0)  PRI  550 

150      WRITE   (IPRINT  ,250)  PRI  560 

155      DO  200    M=1,J  PRI  570 

DO  160  1=1 A , IB  PRI  580 

K=IARGS(I)  PRI  590 

IARGS ( I )=IARGS ( I ) +1  PRI  600 

160      ARGS(I)=RC(K)  PRI  610 

GO  TO  (170,180) ,   IP  PRI  620 

170      WRITE  (IPRINT, KFMT)  ( ARGS ( I ) , 1=1 , NARGS )                                              PRI  630 

GO  TO  200  PRI  640 

180      WRITE   (IPRINT, IFMTX)    (ARGS ( I ) , 1=1 A , IB )  PRI  650 

190      IF   (M0D(M,10) .EQ.O)  WRITE   (IPRINT, 250)                                                  PRI  660 

200      CONTINUE  PRI  670 

ICP=1  PRI  680 

IF   (LL)  210,210,110  PRI  690 

210      GO  TO   (20 ,220)  ,   IP  PRI  700 

220      IF  (IBB. EQ.O)  GO  TO  20                                                                           PRI  710 

IF   (L1.EQ.8)  WRITE(IPRINT,250)  PRI  713 

IA=IB+1  PRI  715 

ICP=0  PRI  720 

GO  TO  80  PRI  730 

C         USE  STANDARD  OR  SPECIFIED  FORMAT  PRI  820 

230      IP=2  PRI  830 

DO  240  1=1, NARGS  PRI  840 

240      KFMT(I)=IARGS(I)  PRI  850 

GO  TO  50  PRI  860 

C  PRI  870 

250      FORMAT  (IX)  PRI  880 

260      CALL  PAGE  (0)  PRI  890 

GO  TO  155  PRI  900 

END  PRI  910 
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SUBROUTINE  PROCHK  (A ,NROW,N ,NCOL , IVEC ,X ,NSIZE)  PRK  10 

C         VERSION    5.00         PROCHK         5/15/70  PRK  20 

C         SUBROUTINE  PROCHK           R  VARNER  5/  7/68                                      PRK  30 

C         R  VARNER    SUBROUTINE  TO  CHECK  FOR  DIAGONAL  .NORMAL , SYMMETRIC ,  PRK  40 

C         SKEW-SYMMETRIC  AND  ORTHOGONAL  MATRIX  PRK  50 

DIMENSION  A(NR0W,1) ,  IVEC(l)  PRK  60 

C         SET  ALL  INDICATORS  TO  NO  CONDITION  PRK  70 

DO  10  1=1,5  PRK  80 

10        IVEC ( I )=2  PRK  90 

C         TEST  TO  SEE  IF  WE  HAVE  A  DIAGONAL  MATRIX  PRK  100 

C          IF  YES     IVEC(1)=0      IF  NO  IVEC(1)=2  PRK  110 

DO  30  I=1,N  PRK  120 

DO  30  J=1,N  PRK  130 

IF   (I-J)  20,30,20  PRK  140 

20        IF   (A(I,J))  40,30,40  PRK  150 

30        CONTINUE  PRK  160 

IVEC(1)=0  PRK  170 

IVEC(2)=0  PRK  180 

IVEC(3)=0  PRK  190 

GO  TO  50  PRK  200 

40        IVEC(1)=2  PRK  210 

C         CHECK  FOR  SUMMETRY  PRK  220 

CALL  SYMV  (A,NR0W,N,IVEC(2) )  PRK  230 

C         CHECK  FOR  SKEW  SYMMETRY  PRK  240 

CALL  SKSYMV  (A ,NROW,N , IRV)  PRK  250 

IF  (IRV.GE.3)  IVEC(2)=IRV  PRK  260 

IF  (IVEC(2)  .EQ.2)  GO  TO  50  PRK  270 

IVEC(3)=0  PRK  280 

C         CHECK  FOR  ORTHOGONAL  MATRIX  PRK  290 

C          IF  A  IS  ORTHOGONAL  IVEC(4)=0      OTHERWISE  IVEC(4)=2  PRK  300 

50        CALL  ORTHRV  (A ,NROW,N ,NCOL , IVEC (4) ,X ,NSIZE ,X)  PRK  310 

RETURN  PRK  320 

END  PRK  330 
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SUBROUTINE  PROROW 

PRO 

10 

c 

VERSION     5.00          PROROW  5/15/70 

PRO 

20 

c 

PROGRAMMED  BY  CARLA  MESSINA    MAY ,1967 

PRO 

30 

c 

L2  =  1,  ROWSUM         L2  =  2,  PRODUCT 

PRO 

40 

COMMON  /BLOCRC/  NRC , RC ( 12600 ) 

PRO 

50 

COMMON  /BLOCKD /  IARGS(IOO) ,KIND(100) ,ARGTAB (100) , NRMAX ,NROW,NCOL ,NPRO 

60 

1ARGS,VWXYZ(8) , NERROR 

PRO 

70 

DIMENSION  ARGS(IOO) 

PRO 

80 

EQUIVALENCE  ( ARGS ( 1 ), RC  ( 12501  ) ) 

PRO 

90 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG 

PRO 

100 

COMMON  /SCRAT/  NS , NS2 , A ( 13500 ) 

PRO 

110 

IF   (NARGS-3 )  10,40,40 

PRO 

120 

10 

IF  (NARGS . EQ  .  1 . AND .KIND (1 ) . EQ . 0 )  GO  TO  230 

PRO 

130 

K=10 

PRO 

140 

20 

CALL  ERROR  (K) 

PRO 

150 

30 

RETURN 

PRO 

160 

40 

CALL  CHKCOL  (J) 

PRO 

170 

IF  (J)  50,60,50 

PRO 

180 

50 

K=3 

PRO 

190 

GO  TO  20 

PRO 

200 

60 

IF   (NRMAX)  70,70,80 

PRO 

210 

70 

K=9 

PRO 

220 

GO  TO  20 

PRO 

230 

80 

IF  (NERROR. NE.O)  RETURN 

PRO 

240 

DO  100  1=1, NRMAX 

PRO 

250 

A(I )=0 .0 

PRO 

260 

GO  TO  (100  ,90) ,  L2 

PRO 

270 

90 

A(I )=1 .0 

PRO 

280 

100 

CONTINUE 

PRO 

290 

IF  (NARGS-4 )  110,190,190 

PRO 

300 

110 

IF  (IARGS(1)-IARGS(2) )  120,120,50 

PRO 

310 

120 

K=IARGS(1) 

PRO 

320 

DO  150  1=1, NRMAX 

PRO 

330 

J=K+I-1 

PRO 

340 

GO  TO  (130,140)  ,  L2 

PRO 

350 

130 

A ( I )=A ( I ) +RC (J ) 

PRO 

360 

GO  TO  150 

PRO 

370 

140 

A(I)=A(I)*RC(J) 

PRO 

380 

150 

CONTINUE 

PRO 

390 

IF  (IARGS(1)+NR0W-IARGS(2))  160,160,170 

PRO 

400 

160 

IARGS(1)=IARGS(1)+NR0W 

PRO 

410 

GO  TO  120 

PRO 

420 

170 

K=IARGS (NARGS) 

PRO 

430 

DO  180  1=1, NRMAX 

PRO 

440 

J=K+I-1 

PRO 

450 

180 

RC(J)=A(I) 

PRO 

460 

GO  TO  30 

PRO 

470 

190 

IUNARGS-1 

PRO 

480 

DO  220  L=1,II 

PRO 

490 

K=IARGS (L) 

PRO 

500 

DO  220  1=1, NRMAX 

PRO 

510 

J=K+I-1 

PRO 

520 

GO  TO  (200,210) ,  L2 

PRO 

530 

200 

A(I)=A(I)+RC(J) 

PRO 

540 

GO  TO  220 

PRO 

550 

210 

A(I)=A(I)*RC(J) 

PRO 

560 

220 

CONTINUE 

PRO 

570 

GO  TO  170 

PRO 

580 

230 

CALL  ADRESS  (1,J) 

PRO 

590 

253 


IF   (J.LE.O)  CALL  ERROR  (3) 

PRO 

600 

DO  250  I=1,NRMAX 

a  a  a 

PRO 

610 

TO  T 

I  R=  I 

PRO 

620 

r  i  Hi  a 

SUM=0 . 

rj  n  A 

PRO 

630 

DO  240  K=l , NCOL 

n  o  A 

PRO 

/    A  A 

640 

SUM=SUM+RC ( IR ) 

AAA 

PRO 

650 

IR=IR+NR0W 

n  o  A 

PRO 

660 

RC (J )=SUM 

PRO 

670 

J=J+1 

PRO 

/OA 

680 

RETURN 

AAA 

PRO 

690 

END 

PRO 

700 
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SUBROUTINE  PUNCH  PUN  10 

C          VERSION    5.00          PUNCH            5/15/70  PUN  20 

C  PUN  30 

C         THE  COMMAND  PUNCH  MAY  BE  USED  IN  THE  FOLLOWING  WAYS  PUN  40 

C              PUNCH    COL  ++,++,++,++     (4  COLUMN  LIMIT)  PUN  50 

C             PUNCH  //  COL  ++f++l++#++>ECT     (ACCORDIND  TO  FORMAT  //)  PUN  60 

C         THIS  SUBROUTINE  IS  USED  TO  EXECUTE  WRITE  TAPE                                    PUN  70 

C              WRITE  TAPE  T  FROM  COL  ++,++,++,++     (4  COLUMN  LIMIT)                     PUN  80 

C              WRITE  TAPE  T  //  FROM  COL  ++,++,  ETC     (USE  FOLMAT//)  PUN  90 

C  PUN  100 

COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG  PUN  110 
COMMON  /BLOCKD/  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NPUN  120 

1ARGS , VWXYZ (8 ) ,NERROR  PUN  130 

COMMON  /BLOCRC/  NRC , RC  ( 12600 )  PUN  140 

DIMENSION  ARGS(IOO)  PUN  150 

EQUIVALENCE  (ARGS ( 1 ) ,RC ( 12501 ) )  PUN  160 

COMMON  /KFMT /  KFMT(IOO)  PUN  170 

COMMON  /FMAT/  IFMTX (6) , IOSWT , IFMTS (6 ) , LHEAD (96 )  PUN  180 

COMMON  /TAPE/  NAME4 (2 ) ,NTPCT , IPUNCP , INUNIP ,LITP  PUN  190 
COMMON  /HEADER/  NOCARD (80 ) , ITLE (60.6) , LNCNT , I  PR  I  NT ,NP AGE , I  PUNCH      PUN  200 

C  PUN  210 

C         Ll=3    PUNCH    Ll=47  WRITE  TAPE  PUN  220 

C  PUN  230 

IX=1  PUN  240 

IF   (L1.EQ.47)   IX=2  PUN  250 

IF  (NARGS.NE.O)  GO  TO  20  PUN  260 

10        CALL  ERROR  (205)  PUN  270 

RETURN  PUN  280 

C  PUN  290 

C         IF  L2=l  ONLY  4  COLUMNS  CAN  BE  PRINTED  PUN  300 

C  PUN  310 

20        IF(L2.NE.l)  GO  TO  25  PUN  320 

NARGS=MINO (NARGS ,4)  PUN  330 

GO  TO  30  PUN  340 

25        CALL  PREPAK  (4 , IND ,L2 , IND , KFMT)  PUN  345 

IF  (IND.NE.O)  GO  TO  90  PUN  350 

30        CALL  CHKCOL  (I)  PUN  360 

IF  (I.NE.O)  GO  TO  10  PUN  370 

IF  (NERROR.NE.O)  GO  TO  (110,100),  IX  PUN  380 

DO  60  1=1, NRMAX  PUN  390 

DO  40  J=l, NARGS  PUN  400 

K=IARGS(J)  PUN  410 

IARGS(J)=K+1  PUN  420 

40        ARGS(J)=RC(K)  PUN  430 

IF  (L2.NE.1)  GO  TO  50  PUN  440 

WRITE  (IPUNCH, IFMTX)   (ARGS (K) ,K=1 , NARGS)  PUN  450 

GO  TO  60  PUN  460 

50        WRITE  (IPUNCH, KFMT)   (ARGS (K) ,K=1 , NARGS)  PUN  470 

60        CONTINUE  PUN  480 

IF  (L1.NE.47)  RETURN  PUN  490 

DO  70  J=l , NARGS  PUN  500 

70       ARGS(J)=0.0  PUN  510 

IF  (L2.NE.1)  GO  TO  80  PUN  520 

WRITE  (IPUNCH, IFMTX)   (ARGS (K) ,K=1 , NARGS)  PUN  530 

GO  TO  100  PUN  540 

80        WRITE  (IPUNCH, KFMT)   (ARGS (K) ,K=1 , NARGS)  PUN  550 

GO  TO  100  PUN  560 

90       CALL  ERROR  (222)  PUN  570 

L2=l  PUN  580 
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bU    1 U  3  0 

n  1 1  ki 

PUN 

590 

1  A  A 

100 

T  DIIMPU    T  Dl  IWPD 

1  r  UIMbrl=l  rUnUr 

n  1 1  hi 
rUN 

z  ft  ft 

600 

110 

RETURN 

PUN 

610 

END 

PUN 

620 

CIIDDnilTINr    D  W  T  D  T     1  h    kIDnill    hi    T  hi  ft  1 1    T  hi  n  O  \ 

bUDKUUIllMt  rvlKl    ( A  ,  IMKU  W  ,  IM  , 1NUU, INOb) 

DV/T 

rv  1 

1  ft 

c 

WCDCTAM        C     A  A                  DWTDT  C/1C/TA 

VtKblUN     5.00           PVIK1  5/15/70 

DV/T 

rv  1 

20 

c 

D\/T 

rv  1 

1 a 

c 

rn    nCTCDUTMC    I  C    A     TC    AW    IIDDCD    AD    1  AIVCD 

IU  Ut  1  tKMl  IMt   lr   A   lb  AIM  UrrtK  UK  LUWtK 

TDTAKinil  AD 

1  K 1  AIMbULAK 

MA  TD T  V 

MA  1 K  1  X 

DV/T 

rv  1 

A  A 

40 

c 

C     DCAWV    CAD    MhlTWAP     1  1  A  0             O  /     T  Ufl 

b  rtAVY   rUK  UIMlVAb   110b         2/  7/68 

rv  1 

C  A 

50 

c 

DV/T 

HV  1 

L  A 

60 

c 

A        UATDTV     TA     DC  PUCP1/CA 

A     MAIK1X    IU  Bt  bntbKtU 

DV/T 

rv  1 

t  A 
70 

C 

hi  D  A  \A1       AT  KIC  MCTAM     C  T  7  C     AC  A 

NKUW-  UlMtlMblUlM  b  I  Z,t  Ur  A 

Dl/T 

Kv  1 

O  A 

80 

L 

Kl            DDCCCKIT    CI7C    ftc  A 

IM-       rKtbtIM  1    blZ.t  Ur  A 

DWT 

rv  1 

Q  A 
90 

L 

TKIftll    TMnTPHTrtD       TKinil    A    IIDDPD    TDIAWn  C 
1  IMUU    1  WD  1  OA  1  UK      1  IMUU  =  U  ,  UrrtK    1  K  1  AIMbLt  = 

A       T  U ftl  I  1 
U  ,    1  IMUU=1  , 

UPPER  TRIANGLE 

hi  n  D  W  T 

IMUr  V  1 

1  A  A 

100 

b 

TlinD     A     DftTTAU  TDTAI 

1NUd=0,dUI 1 UM   IK1AL  = 

A        T  Kl  A  D  1 

0  ,    1 NUb=l  , 

BOTTOM 

NOT 

irnuT 

Ltr  V  1 

1  1  A 

110 

b 

rv  1 

1  O  A 

120 

ftTMCKICTAhl    A  /  hlDAUU  hIDAUM 

UlMtlMblUlM  A  ( IMKU W ,  IMKU W) 

DX/T 

rv  1 

1  1  A 

130 

T  Kl  A  1 1  1 
1  IMUU=1 

DMT 

rv  1 

1  VI  A 

140 

T  hi  A  D  1 

1  IMUb=l 

D\/T 

rv  1 

1  C  A 

150 

hi  Kl     Kl  1 

NIM=IM-1 

KV  1 

1  L  A 

160 

A  A     C  A     T      1     Kl  Kl 

UU  50   1  =  1 ,  IMIM 

DV/T 

r  V  1 

1  7  A 

170 

T  T  Til 

1 1=1+1 

D\/T 

rv  1 

1  O  A 

180 

nn  c  a    i    T  T  Ki 
uu  do  J  =  1 1 , im 

D\/T 

rv  1 

1  OA 
17U 

rn    TA     MA    in  I  TKIAII 
uU    IU    (1U,2U),    1  IMUU 

D\/T 

rv  1 

O  A  A 
2UU 

1  A 
10 

TC     /A/T      l\     Kl  C    A     \     TKIAII  *> 

lr    ( A  ( 1  ,  J  )  .  IMt  .  0  .  )  1IMUU=2 

D\/T 

rv  1 

1  1  A 
210 

o  a 

rA    TA     1  1  (\    VI  A  \  TKIAD 

bU    IU    (30,40),  lIMUb 

D\/T 

rv  1 

*5  O  A 

220 

■a  a 
JO 

TC     /  A  /  1     T\    KIC    A     \     TKIAD  O 

lr    (A  ( J  ,  1  )  .  1Mb  .  0  .  )  llMUb=2 

DUT 

rv  1 

O  7  A 

230 

40 

TC     /TKIAII    CA    O    AKIA    TKIAD    CA    0\    m    TA    L  A 

lr    ( 1  IMUU  .  tU.  .  i  .  AIMU  .  1  NUB  .  tU,  .  L  )   bU    IU  60 

DWT 

rv  1 

O  A  A 

240 

c  a 
DO 

P  A  KIT  T  Ml  IC 
bUlM  1  1  IMUt 

D\/T 

rv  1 

OCA 
2DU 

L  A 

60 

T  Kl  A 1 1     T  Kl  A 1  1  1 

1  IMUU=1  IMUU-1 

D\/T 

rv  1 

O  L  A 

260 

TKIAD     TKIAD  1 

1  IMUb=l  IMUb-1 

D\/T 

rv  1 

O  7  A 

2  70 

npTt  inn 

RETURN 

PV  1 

i  fi  n 

280 

END 

PVT 

290 
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4/9/69 


R,  CARRY  ALONG  I  IN  H  TO  OBTAIN  HIERARCHY  IN  H 
'PUSH-DOWN'  METHOD .  SEE  ORGANICK,  PAGE  84. 


THEN  I*  =  I-(K-l) /2 . 


SUBROUTINE  RANKO  (N,X,H,R,T) 
C         VERSION    45.0        RANKO        3/  6/70 
DIMENSION  X(l)  ,  H(l)  ,  R (1) 

Q  ***** 

C         PUTS  RANK  OF  N  X'S  IN  VECTOR  R.  VECTOR  H  IS  USED  FOR  STORAGE 
C         X,H  AND  R  MUST  BE  DIMENSIONED  N  OR  GREATER. 
C         STORES  CORRECTION  FOR  TIES  IN  T  =  (1/12) *SUM(T-1) *T* (T+l ) . 
C         T=0    MEANS  NO  TIES. 
C         WRITTEN  BY  DAVID  HOGBEN ,  SEL, 
C         MOVE  X  TO  R  AND  PUT  I  IN  H 
10        DO  20  I=1,N 

H (I )=I 
20        R  ( I  )=X  ( I ) 
C         SORT  X  IN 
C         SORT  USES 

K1=N-1 

DO  30  1=1, Kl 
K2=N-I 

DO  30  J=1,K2 

IF  (R(J) .LE.R(J+1) )  GO  TO  30 

W=R(J) 

R(J)=R(J+1) 

R(J+1)=W 

W=H(J) 

H(J)=H(J+1) 

H(J+1)=W 
30  CONTINUE 
C         REPLACE  R(I)  BY  I*. 

C         LET  K  BE  SUCH  THAT  R ( I )=R ( I-J+l ) , J=l ,K 
K=l 
T=0 

DO  70  1=2, N 

IF   (R(I)-R(I-l))  50,40,50 
40  K=K+1 

GO  TO  70 
50        DO  60  J=l ,K 

IJ=I-J 

60        R(IJ)=FL0AT(I-l)-FL0AT(K-l)/2 . 

IF  (K.GT.l)  T=T+(FLOAT(K-1)*FLOAT(K)*FLOAT(K+1))/12.0 
K=l 

70  CONTINUE 

T  =  T  +  (FL0AT(K-1)*FL0AT(K)*FL0AT(K+1))/12.0 
DO  80  1=1, K 
K2=N+1-I 

80        R(K2)=FL0AT(N)-FL0AT(K-l)/2 .0 
C         SORT  H  CARRY  ALONG  R  TO  OBTAIN  RANKS  IN  R 

DO  90  1=1, Kl 

K2=N-I 

DO  90  J=1,K2 

IF  (H(J) .LE.H(J+1))  GO  TO  90 
W=H(J) 
H(J)=H(J+1) 
H(J+1)=W 
W=R(J) 
R(J)=R(J+1) 
R(J+1)=W 
90  CONTINUE 
RETURN 
END 


RKO 
RKO 
RKO 
RKO 
RKO 
RKO 
RKO 
RKO 
RKO 


10 
20 
30 
40 
50 
60 
70 
80 
90 


RKO  120 
RKO  130 
RKO  140 
RKO  150 
RKO  160 
RKO  170 
RKO  180 
RKO  190 
RKO  200 
RKO  210 
RKO  220 
RKO  230 
RKO  240 
RKO  250 
RKO  260 
RKO  270 
RKO  280 
RKO  290 
RKO  300 
RKO  310 
RKO  320 
RKO  330 
RKO  340 
RKO  350 
RKO  360 
RKO  370 
RKO  380 
RKO  390 
RKO  400 
RKO  410 
RKO  420 
RKO  430 
RKO  440 
RKO  450 
RKO  460 
RKO  470 
RKO  480 
RKO  490 
RKO  500 
RKO  510 
RKO  520 
RKO  530 
RKO  540 
RKO  550 
RKO  560 
RKO  570 
RKO  580 
RKO  590 
RKO  600 
RKO  610 
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SUBROUTINE  RANKS  RAS  10 

C         VERSION    5.00         RANKS           5/15/70  RAS  20 

C         *****  RAS  30 

C         VERSION  3.05  COMMON  RAS  40 

COMMON  /BLOCRC/  NRC  , RC  ( 12600 )  RAS  50 

COMMON  /BLOCKD/  IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NRAS  60 

1ARGS ,VWXYZ (8) ,NERROR  RAS  70 

DIMENSION  ARGS(IOO)  RAS  80 

EQUIVALENCE  (ARGS ( 1 ), RC ( 12501 ) )  RAS  90 

COMMON  /SCRAT/  NS , NS2 , A  ( 13500 )  RAS  100 

COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG  RAS  110 

C         *****  RAS  120 

C         RANKS  OF  VALUES  IN  COLUMN  ++  PUT  IN  COLUMN  ++.  TIES  ARE  ALLOWED.     RAS  130 

C         ADJUSTMENT  T= ( 1 /12 ) *SUM(T-1 ) *T* (T+l )  FOR  FURTHER  CALCULATIONS  IS    RAS  140 

C         PUT  IN  ROW  (NRMAX+1)  IF  NRMAX  LT  NROW.  RAS  150 

C         *****  RAS  160 

10        IF  (NARGS.EQ.2)  GO  TO  20  RAS  170 

CALL  ERROR  (10)  RAS  180 

RETURN  RAS  190 

20        CALL  ADRESS  (1,J1)  RAS  200 

CALL  ADRESS  (2,J2)  RAS  210 

IF  (J1.GT.0.AND.J2.GT.0)  GO  TO  30  RAS  220 

CALL  ERROR  (3)  RAS  230 

RETURN  RAS  240 

30        IF  (NRMAX. GT.O)  GO  TO  40  RAS  250 

CALL  ERROR  (9)  RAS  260 

RETURN  RAS  270 

40        IF  (NERROR.NE.O)  RETURN  RAS  280 

CALL  RANKX  (NRMAX , RC ( J 1 ) , A (2 ) , RC ( J2 ) , A ( 1 ) )  RAS  290 

IF  (NRMAX. GE. NROW)  RETURN  RAS  300 

JANR=J2+NRMAX  RAS  305 

RC(JANR)=A(1)  RAS  310 

RETURN  RAS  320 

END  RAS  330 
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c 
c 
c 
c 
c 
c 
c 
c 
c 

10 
20 

c 
c 


30 

C 

C 


40 
50 
60 

70 


80 
C 


90 


SUBROUTINE  RANKX  (N,X,H,R,T) 

VERSION    5.00         RANKX  5/15/70 

DIMENSION  X(l) ,  H(l) ,  R(l) 
***** 

PUTS  RANK  OF  N  X'S  IN  VECTOR  R.  VECTOR  H  IS  USED  FOR  STORAGE 
X,H  AND  R  MUST  BE  DIMENSIONED  N  OR  GREATER. 
STORES  CORRECTION  FOR  TIES  IN  T  =  (1/12) *SUM(T-1) *T* (T+l ) . 
T=0    MEANS  NO  TIES. 

WRITTEN  BY  DAVID  HOGBEN,  SEL,  NBS .  4/9/69. 

COMPUTATION  OF  T  CORRECTED  8/26/69 
***** 

MOVE  X  TO  R  AND  PUT  I  IN  H 

DO  20  1=1, N 

H(I)=I 

R(D=X(I) 

SORT  X  IN  R,  CARRY  ALONG  I  IN  H  TO  OBTAIN  HIERARCHY  IN  H. 
SORT  USES  'PUSH-DOWN'  METHOD.  SEE  ORGANICK,  PAGE  84. 
K1=N-1 

DO  30  1=1 ,K1 
K2=N-I 

DO  30  J=1,K2 

IF  (R(J) .LE.R(J+1) )  GO  TO  30 

W=R(J) 

R(J)=R(J+1) 

R(J+1)=W 

W=H(J) 

H(J)=H(J+1) 

H(J+1)=W 

CONTINUE 

REPLACE  R(I)  BY  I*. 

LET  K  BE  SUCH  THAT  R ( I )=R ( I-J+l ) , J=l ,K 
K=l 
T=0 

DO  70  1=2, N 

IF   (R(I)-R(I-l) )  50,40,50 
K=K+1 
GO  TO  70 
DO  60  J=1,K 
IJ=I-J 

R(IJ)=FL0AT(I-l)-FL0AT(K-l)/2. 

IF  (K.GT.l)  T=T+(FL0AT(K-1)*FL0AT(K)*FL0AT(K+1))/12.0 
K=l 

CONTINUE 

T  =  T  +  (FL0AT(K-1)*FL0AT(K)*FL0AT(K+1))/12.0 
DO  80  1=1, K 
K2=N+1-I 

R (K2 )=FL0AT (N ) -FLOAT (K-l ) /2 . 0 
SORT  H  CARRY  ALONG  R  TO  OBTAIN  RANKS  IN  R 
DO  90  1=1, Kl 
K2=N-I 

DO  90  J=1,K2 

IF  (H(J).LE.H(J+1))  GO  TO  90 
W=H(J) 
H(J)=H(J+1) 
H(J+1)=W 
W=R(J) 
R(J)=R(J+1) 
R(J+1)=W 
CONTINUE 
RETURN 
END 
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THEN  I*  =  I-(K-l)/2 


RAX 
RAX 
RAX 
RAX 
RAX 
RAX 
RAX 
RAX 
RAX 
RAX 


10 
20 
30 
40 
50 
60 
70 
80 
90 
95 


RAX  100 
RAX  110 
RAX  120 
RAX  130 
RAX  140 
RAX  150 
RAX  160 
RAX  170 
RAX  180 
RAX  190 
RAX  200 
RAX  210 
RAX  220 
RAX  230 
RAX  240 
RAX  250 
RAX  260 
RAX  270 
RAX  280 
RAX  290 
RAX  300 
RAX  310 
RAX  320 
RAX  330 
RAX  340 
RAX  350 
RAX  360 
RAX  370 
RAX  375 
RAX  380 
RAX  390 
RAX  400 
RAX  410 
RAX  415 
RAX  420 
RAX  430 
RAX  440 
RAX  450 
RAX  460 
RAX  470 
RAX  480 
RAX  490 
RAX  500 
RAX  510 
RAX  520 
RAX  530 
RAX  540 
RAX  550 
RAX  560 
RAX  570 
RAX  580 


r  i  i  n  n  a  i  i  t  t  hi-     n  a  r  i  i  ft  a      /  *      ki  n  /\  in    ai     i/     n  \ 

SUBROUTINE  RCSUM  (A ,NROW,N ,K ,R) 

RCS 

10 

c 

w  r  ri  f  ?  A  in          r*      a  ft                             r  1  III                         r~    i  ~\  r    i  ~/  r\ 

VERSION    5.00         RCSUM  5/15/70 

p>  ft  p 

RCS 

20 

c 

WRITTEN    BY  S  PEAVY  11/22/67 

RCS 

30 

c 

RCS 

40 

c 

WHERE : 

RCS 

50 

c 

a          TP        i     AAc   T  T  ft  ft  1        ft  P*        111  T  Pi  T  vy        T  A       ft  P        P  1  1  ft  II  IP  p.        pi  ft  in 

A  IS  LOCATION  OF  MATRIX  TO  BE  SUMMED  ROW 

AND 

COLUMN  WISE 

RCS 

60 

c 

ft  ■  r"\  a  in          r  y  ^  p      rv  p       *       t  ik  i      rv  t  b  ip  ft  i  p  t  A  ft  i      p  t  ft  t  r  ■  ir  ft  i  t 

NR0W    SIZE  OF  A  IN  DIMENSION  STATEMENT 

A(NR0W,NR0W) 

RCS 

70 

c 

fti          a  i  pi      a  r      ft  /*v  in r       t  ft i  ft 

N    NO  OF  ROWS  IN  A 

RCS 

80 

c 

IS             ft  1  ft        ftP        A  A  I     P         f  ft  I  ft 

K    NO  OF  COLS  IN  A 

ft  p<  p 

RCS 

90 

c 

p\        nrrin  t"  p 

R  RESULTS. 

ft  ft  p 

RCS 

100 

c 

rt/^v            Pk/i/\         p»  p\  i      r  I  I  nr 

R  ( 1 )  .  .  R (K)     COL  SUMS 

ft  ft  r 

RCS 

110 

c 

R(K+1)..  R(K+N)  ROW  SUMS 

pi  ft  p 

RCS 

120 

ft 

c 

p\  / 1/    ft i    -1  ,        rn  inn  run 

R(K+N+2)     GRAND  SUM 

RCS 

130 

ft 

c 

pk  /  i  /           t  ,         p>     &  /  t      iv        An     aii      t  a 

R(K+N  +  1)     S  A ( I  , J )  FOR  ALL  I,J. 

RCS 

T    ill  A 

140 

c 

ft    /  1/      ft  1      i\            C       A    /  T         J  \  A  A  A      p  p\  p»       All         T  1 

R(K+N+3)     S  A(I,J)**2  FOR  ALL  I ,J . 

ft  ft  r 

RCS 

150 

c 

p*   <  ■  /      ft  i       •  ,       p  ■  i  ft  «     ftp      *  p\  p  ft  i    ii  *p  p      ii  i  i    i  i  t—  p  ftp 

R(K+N+4)  SUM  OF  ABSOLUTE  VALUES  OF 

A  1  1 
ALL 

AM     I  ^ 
A  ( 1  ,  J  ) 

RCS 

160 

ft 

c 

n  ft  r 

RCS 

170 

ft    T   ft  ftP  ft  1  P    T   ft  ft  ■          ft      *  ft  1  ft  ft  lit       ft  1  ft  ft  lit  %                  ft     s  ft.  1  v 

DIMENSION  A (NR0W,NR0W) ,  R(N) 

RCS 

180 

L=l 

p»  ft  p 

RCS 

190 

ASUM=0 . 

pv  ft  r 

RCS 

200 

ft  ft     ft  ft       i      ^  1/ 

DO  20  J=l , K 

ft  ft  p 

RCS 

210 

SUM=0 . 

ft  ft  p 

RCS 

220 

r»  />    i  ft    t     i  hi 

DO  10  1=1, N 

D  r*  C 

RLb 

230 

■  run    &  p  i  i  •,  a    k  n  c  /  k  /  t      i  \  \ 

ASUM=ASUM+ABS (A ( I , J ) ) 

RLb 

1  A  A 

240 

10 

run    r  i  in    a  /  t  iv 

SUM=SUM+A(I ,J) 

RCS 

ft  p  A 

250 

p»  .  i    .      ^  i  hi 

R (L )=SUM 

p>  ft  r 

RCS 

260 

20 

L=L+1 

RCS 

270 

S=0  .0 

p»  ft  p 

RCS 

280 

SS=0 .0 

r>  ft  r 

RCS 

290 

ft  ft         aft        T  ft! 

DO  40  1=1, N 

ft  p»  r* 

RCS 

300 

SUM=0 .0 

p»  ft  p" 

RCS 

310 

r\ft     i  p.       i      ■!  i/ 

DO  30  J=1,K 

O  1  A 

320 

run     r  i  tn     a   /  7       i  \ 

SUM=SUM+A ( I , J ) 

RC5 

O  O  A 

330 

30 

PP          PP          ft      ,    T            1    v     *t  *S 

SS=SS+A(I ,J)**2 

O  c 

RCS 

O  A  A 

340 

r     p  rim 

S=S+SUM 

DOC 

OCA 

350 

ft>>  pit** 

R (L)=SUM 

ft  ft  r 

RCS 

360 

40 

L=L+1 

D  C 

RCS 

OTA 

370 

R (L)=S 

Rtb 

O  O  A 

380 

R (L+2 )=SS 

npr 

RLb 

O  A  A 

390 

ft       /     |                  ^       V  P 

R  (L+1)=S 

DP  C 

RLb 

400 

ft     i    a            At            ft   P  1  1  ft  ft 

R (L+3 )=ASUM 

RCS 

A  T  A 

410 

RETURN 

ft  ft  r 

RCS 

420 

END 

RCS 

430 
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SUBROUTINE  READQ 

REQ 

10 

c 

VERSION    5.00         READQ  5/15/70 

REQ 

20 

COMMON  /BLOCRC/  NRC , RC  ( 12600 ) 

REQ 

30 

COMMON  /BLOCKD /  IARGS(IOO) , KIND (100) , ARGTAB (100 ) , NRMAX , NROW , NCOL , NREQ 

40 

1ARGS,VWXYZ(8) ,NERROR 

REQ 

50 

DIMENSION  ARGS(IOO) 

REQ 

60 

EQUIVALENCE  (ARGS (1) ,RC (12501) ) 

REQ 

70 

COMMON  /QRS /  NDROW, I  FLAG, J ,NNARG 

REQ 

80 

COMMON  /BLOCKA/  MODE , M, KARD (83 ) ,KARG , ARG , ARG2 ,NEWCD (80 ) , KRDEND 

REQ 

90 

COMMON  /BLOCKC/  KIO , INUNIT , ISCRAT , KBDOUT , KRDKNT , LLI ST 

REQ 

100 

COMMON  /TAPE/  NAME4 (2 ) , NTPCT , IPUNCP , INUNI P , L1TP 

REQ 

110 

COMMON/KFMT/KFMT (100 ) 

REQ 

115 

IF  (IFLAG.NE.O)  GO  TO  80 

REQ 

120 

IF  (J.LT.NROW)  GO  TO  10 

REQ 

130 

IFLAG=1 

REQ 

140 

CALL  ERROR  (201) 

REQ 

150 

GO  TO  40 

REQ 

160 

c 

NNARG  CONTAINS  NARGS  OF  READ  COMMAND 

REQ 

170 

c 

KFMT (l)THRU  KFMT (NNAGR )  CONTAINS  ADDRESSES  OF  COLUMN  TOPS 

REQ 

180 

c 

THESE  CORRECTIONS  ARE  NEEDED  FOR  TAPE  OPERATIONS 

REQ 

190 

10 

IF  (L1TP.NE.45)  GO  TO  50 

REQ 

200 

DO  30  1=1 , NNARG 

REQ 

210 

K=KFMT(I)+J 

REQ 

220 

IF  (KIND (I ) .EQ.O)  GO  TO  20 

REQ 

230 

IF  (ARGS(I) .NE.O. )  GO  TO  50 

REQ 

240 

GO  TO  30 

REQ 

250 

20 

IF  (IARGS(I) .NE.O)  GO  TO  50 

REQ 

260 

30 

CONTINUE 

REQ 

270 

40 

INUNIT=INUNIP 

REQ 

280 

M0DE=1 

REQ 

290 

GO  TO  80 

REQ 

300 

50 

IF  (NARGS. GE. NNARG)      GO  TO  55 

REQ 

305 

NNS=NARGS+1 

REQ 

307 

DO  52  I=NNS , NNARG 

REQ 

310 

KIND(I)=0 

REQ 

315 

52 

IARGS(I)=0 

REQ 

320 

55 

DO  70  1=1 ,NNARG 

REQ 

325 

C 

**************************************************************** 

REQ 

330 

K=KFMT(I)+J 

REQ 

340 

IF  (KIND ( I ) .EQ.O)  GO  TO  60 

REQ 

350 

RC(K)=ARGS(I) 

REQ 

360 

GO  TO  70 

REQ 

370 

60 

RC(K)=IARGS(I) 

REQ 

380 

70 

CONTINUE 

REQ 

390 

C 

J  IS  CARD  COUNT.  IT  COUNTS  FROM  ZERO. 

REQ 

400 

J=J+1 

REQ 

410 

NRMAX=MAXO (NRMAX , J ) 

REQ 

420 

C 

THESE  CORRECTIONS  ARE  NEEDED  FOR  TAPE  OPERATIONS 

REQ 

430 

IF  (L1TP.NE.46)  GO  TO  80 

REQ 

440 

NTPCT=NTPCT-1 

REQ 

450 

IF  (NTPCT. EQ.O)  GO  TO  40 

REQ 

460 

C 

*****************************************************************!| 

REQ 

470 

80 

RETURN 

REQ 

480 

END 

REQ 

490 
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SUBROUTINE  READX  REX  10 

C         VERSION    5.00         READX           5/15/70  REX  20 

COMMON  /BLOCKA /  MODE , M,KARD (83 ) ,KARG ,  ARG , ARG2 ,NEWCD (80 ) (KRDEND        REX  30 

COMMON  /BLOCRC/  NRC ,RC  (12600)  REX  40 

COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NREX  50 

1ARGS ,VWXYZ (8 ) ,NERROR  REX  60 

DIMENSION  ARGS(IOO)  REX  70 

EQUIVALENCE  ( ARGS ( 1 ), RC ( 12501 ) )  REX  80 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , ISRFLG  REX  90 

COMMON  /QRS /  NDROW, I  FLAG , J ,NNARG  REX  100 

COMMON  /BLOCKC/  KIO , I NUN IT , ISCRAT , KBDOUT , KRDKNT , LLIST  REX  110 

C         THE  FOLLOWING  CARD  IS  NEEDED  ONLY  FOR  TAPE  OPERATIONS                       REX  120 

COMMON  /TAPE/  NAME4 (2 ) ,NTPCT , IPUNCP , I NUN  IP ,  L1TP  REX  130 

q          ***************************************************************  140 

COMMON /KFMT /KFMT (100)  REX  150 

IF  (L2.NE.1)  GO  TO  90  REX  170 

ISRFLG=0  REX  180 

IF  (NARGS.GT.O)  GO  TO  20  REX  190 

10    CALL  ERROR  (10)  REX  200 

GO  TO  70  REX  210 

20    M0DE=2  REX  220 

CALL  CHKCOL  (I)  REX  230 

IF(I.EQ.O)  GO  TO  40  REX  240 

30    CALL  ERROR  (3)  REX  250 

GO  TO  70  REX  260 

40     IF  (NERROR.NE.O)  GO  TO  70  REX  270 

DO  50  1=1, NARGS  REX  280 

KFMT(I)=IARGS(I)  REX  290 

IARGS(I)=0  REX  300 

50    ARGS(I)=0.  REX  310 

I FLAG=0  REX  320 

J=0            *  REX  330 

NNARG=NARGS  REX  340 

GO  TO  80  REX  350 

60    M0DE=2  REX  360 

70     IFLAG=1  REX  370 

C         THE  FOLLOWING  CARDS  ARE  NEEDED  ONLY  FOR  TAPE  OPERATIONS  REX  380 

IF  (LITP.EQ.46.0R.LITP.EQ.45)  GO  TO  200  REX  390 

Q                     ******************************************************************p£X  4QQ 

80        RETURN  REX  410 

C  REX  430 

C                        FORMATTED  READ  REX  435 

C                        READ  X  N  C  C  C  C  REX  440 

C  REX  450 

C                        N  =  NUMBER  OF  CARDS  TO  READ.  IF  N  =  0,  READ  UNTIL  A           REX  460 

C                        BLANK  CARD  IS  FOUND  REX  470 

C                        X  IS  THE  FORMAT  IDENTIFIER,  A,B(C,D,E,F  REX  480 

C  REX  490 

90        IF (NARGS . LE .  1 )  GO  TO  10  REX  500 

C                        SETUP  FORMAT  REX  510 

CALL  PREPAK(4, IND,L2,I , KFMT)  REX  520 

IF  (IND.NE.O)     CALL  ERROR  (27)  REX  525 

IF  (NERROR.NE.O)    GO  TO  60  REX  530 

C                        CHECK  AND  CONVERT  ARGUMENTS  REX  540 

DO  100  1=2, NARGS  REX  550 

CALL  ADRESS  ( I , IARGS ( I ) )  REX  560 

IF ( IARGS ( I ) . LE . 0 )  GO  TO  185  REX  565 

100      CONTINUE  REX  567 

IF(IARGSd))  30,110,120  REX  570 
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110 

120 
130 


140 

C 

C 

150 


160 
170 

180 


C 
C 

C 

185 

C 

C 

190 
200 


C 
C 

210 


N=NRC 

GO  TO  130 

N=IARGS(1) 

00  170  1=1, N 

READ  (INUNIT ,KFMT)   (ARGS (J ) , J=2 ,NARGS) 

CHECK  IF  LOOKING  FOR  BLANK  CARD 
IF  (IARGS(l) .NE.O)  GO  TO  150 
DO  140  J=2,NARGS 
IF  (ARGS(J) .NE.O. )  GO  TO  150 
CONTINUE 

BLANK  CARD  FOUND,  TERMINATE  READ. 

GO  TO  180 

IF  THERE  IS  TOO  MUCH  DATA,  DO  NOT  ENTER  EXCESS 
IF  (I.GT.NROW)  GO  TO  170 
DO  16Q  J=2,NARGS 
K=IARGS(J) 
IARGS(J)=K+1 
RC(K)=ARGS(J) 
CONTINUE 
I=N+1 

1  =  1-1 

NRMAX=MAX0 (NRMAX , MI  NO (I ,NROW) ) 

WRITE  (ISCRAT,210)  I 

IF  (I.GT.NROW)  CALL  ERROR  (201) 

THE  FOLLOWING  CARDS  ARE  NEEDED  ONLY  FOR  TAPE  OPERATIONS 
THE  CARD  WAS  GO  TO  80 
GO  TO  190 

************************************************************* 
CALL  ERROR  (11) 

THE  FOLLOWING  CARD  IS  NEEDED  ONLY  FOR  TAPE  OPERATIONS 

THE  CARD  WAS  GO  TO  80 

IF(L1TP.NE.45 .AND .L1TP .NE .46)  RETURN 

INUNIT=INUNIP 

M0DE=1 

RETURN 

*********************************************************** 

FORMAT  (5X,I4,33H  DATA  CARD(S)  READ  BUT  NOT  LISTED,  42X) 
END 


REX  580 

REX  590 

REX  600 

REX  610 

REX  620 

REX  630 

REX  640 

REX  650 

REX  655 

REX  657 

REX  660 

REX  670 

REX  680 

REX  690 

REX  700 

REX  710 

REX  720 

REX  730 

REX  740 

REX  750 

REX  760 

REX  770 

REX  780 

REX  790 

REX  800 

REX  810 

REX  820 

*****REX  830 

REX  840 

REX  850 

REX  860 

REX  870 

REX  880 

REX  890 

REX  900 

*****REX  910 

REX  920 

REX  930 

REX  940 
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SUBROUTINE  REPINC  (IJSWT)  REP  10 

C         VERSION    5.00         REPINC         5/15/70  REP  20 

C         WRITTEN  BY  R  VARNER        4/  9/68  REP  30 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG  REP  40 

COMMON  /BLOCKB/  NSTMT ,NSTMTX , NSTMTH ,NCOM,LCOM, IOVFL , COM (2000)  REP  50 

COMMON  /BLOCKX/  INDEX (6,8) , LEVEL  REP  60 

COMMON  /BLOCRC/  NRC , RC  ( 12600 )  REP  70 

COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NREP  80 

1ARGS ,VWXYZ (8) ,NERROR  REP  90 

DIMENSION  ARGS(IOO)  REP  100 

EQUIVALENCE  (ARGS (1 ) ,RC (12501) )  REP  110 

C  REP  120 

C          IJSWT=1  COMMAND  IS  REPEAT    INITIALIZE  THINGS                                      REP  130 

C          IJSWT=2    IN  REPEAT  MODE  REP  140 

C          IJSWT=3  COMMAND  IS  INCREMENT  OR  RESTORE  REP  150 

C  REP  160 

C         L2=6    INCREMENT  REP  170 

C         L2=8    RESTORE  REP  180 

C  REP  190 

GO  TO  (350,490,10),   IJSWT  REP  200 

10        IF  (L2.EQ.6)  GO  TO  20  REP  210 

T=0.0  REP  220 

GO  TO  30  REP  230 

20        T=1.0  REP  240 

30        IF  (NARGS.GE.2)  GO  TO  50  REP  250 

40        K=10  REP  260 

GO  TO  320  REP  270 

C  REP  280 

C         GET  STATEMENT  NUMBER.  CAN  BE  FLOATING  OR  INTEGER.                              REP  290 

C  REP  300 

50        IF  (KIND(l) .EQ.O)  GO  TO  60  REP  310 

J=10 .*ARGS(l)+.5  REP  320 

GO  TO  70  REP  330 

60        J=10*IARGS(1)  REP  340 

70        IF  (J .GT.NSTMTH)  GO  TO  80  REP  350 

J=LOCATE(J)  REP  360 

C  REP  370 

C         J  HAS  LOCATION  OF  COMMAND  TO  BE  MODIFIED  REP  380 

C  REP  390 

IF  (J.GT.O)  GO  TO  90  REP  400 

80        K=13  REP  410 

GO  TO  320  REP  420 

C  REP  430 

C         JJ  IS  FIRST  LOCATION  OF  THE  NEXT  STORED  COMMAND.                               REP  440 

C  REP  450 

90        JJ=J+IFIX(C0M(J+1) )  REP  460 

C  REP  470 

C         CHECK  THAT  COMMAND  HAS  THE  PROPER  NUMBER  OF  ARGUMENTS  REP  480 

C  REP  490 

IF  (NARGS-l.NE.M0D(IFIX(C0M(J+2)) ,64))  GO  TO  40                                 REP  500 

J=J+3  REP  510 

C  REP  520 

C         SKIP  OVER  HEADER  REP  530 

C  REP  540 

C  REP  550 

C         CHECK  IF  THIS  COMMAND  IS  STORED.   IF  SO,  PULL  OUT  INTO  ARGTAB.          REP  560 

C          (ALL  BUT  FIRST    ARG  WHICH     IS  STATEMENT  NUMBER)                                 REP  570 

C  REP  580 

IF  (LEVEL. EQ.O)  GO  TO  110  REP  590 
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K=2*NARGS  REP  600 

DO  100  1=2, K  REP  610 

ARGTAB(I)=C0M(I2+4)  REP  620 

100      12=12+1  REP  630 

C  REP  640 

C         12  IS    LOCATION  OF  THIS  COMMAND  REP  650 

C  REP  660 

110      I=2+KIND(1)  REP  670 

C  REP  680 

C         PERFORM  INCREMENT  OR  RESTORE.  PICK  UP  ARGUMENT  FROM                        REP  690 

C         COMMAND  TO  BE  MODIFIED  AND  EXAMINE  IT.  REP  700 

C  REP  710 

120      IF   (COM(J))  250,130,200  REP  720 

C  REP  730 

C         FLOATING  POINT    CONST.  REP  740 

C  REP  750 

130      IF   (ARGTAB ( I ) )   140,160,310  REP  760 

C  REP  770 

C         INCR.  FL.  PT.  CONST.  BY     'STATEMENT'  REP  780 

140      IF (ARGTAB ( I ) . EQ . (-1 . ) )     GO  TO  310  REP  790 

CALL  XPND  (ARGTAB(I) ,K,Y,KND)  REP  800 

IF  (K.LT.O)  GO  TO  220  REP  810 

IF  (KND.EQ.O)  GO  TO  310  REP  820 

C0M(J+1)=T*C0M(J+1)+Y  REP  830 

J=J+2  REP  840 

150      I=I+K+1  REP  850 

GO  TO  190  REP  860 

160      C0M(J+1)=T*C0M(J+1)+ARGTAB(I+1)  REP  870 

170      J=J+2  REP  880 

180      1=1+2  REP  890 

190      IF  (J-JJ)  120,330,330  REP  900 

C  REP  910 

C         COLUMN  NUMBER  REP  920 

C  REP  930 

200      IF  (ARGTAB ( I ) )  210,310,230  REP  940 

C  REP  950 

C         INTEGER  CONST  MODIFIED  BY     STATEMENT:  REP  960 

C  REP  970 

210      IF(ARGTAB(I) .EQ. (-1. ) )     GO  TO  310  REP  980 

CALL  XPND  (ARGTAB (I ) ,K ,  Y ,KND)  REP  990 

IF  (K.GE.O)  IF  (KND)  310,225,310  REP  995 

220      K=-K  REP1000 

GO  TO  320  REP1010 

225      COM(J)=T*COM(J)+Y  REP1020 

J=J+1  REP1030 

GO  TO  150  REP1040 

230      C0M(J)=T*(C0M(J)-8192.)+ARGTAB(I)  REP1050 

IF  (COM(J))  300,300,240  REP1060 

240      J=J+1  REP1070 

1=1+1  REP1080 

GO  TO  190  REP1090 

C  REP1100 

C         VARIABLE    *REFERENCE*  REP1110 

C         NRMAX,V(W,X,Y,Z    CAN  ONLY    BE  INCREMENTED,  BY  0  OR  0 .  REP1120 

C         WHETHER    0    OR    0.     INCREMENTS     :X:  OR  'X'  IS  IMMATERIAL.  REP1130 

C  REP1140 

250      IF(COM(J) .LT. (-16. ) )  GO  TO  260  REP1150 

IF(COM(J) .EQ. (-1.))    GO  TO  340  REP1160 

J=J+1  REP1170 
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c 
c 
c 

260 
270 


280 

290 

300 

310 

320 

330 

C 

C 

C 

C 

340 


C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 

350 

360 

C 

C 

C 

370 

C 
C 
C 

380 


390 
400 

410 


GO  TO  180 

*ROW,COL*  REFERENCE. 

IF  (ARGTAB(I)+16.0)  270,310,310 

COM(J)=T* (COM (J ) +8208 . ) +ARGTAB ( I ) 

IF(COM(J) .GT. (-16.))     GO  TO  310 

IF  (C0M(J+1)*ARGTAB(I+1) )  310,310,280 

Y=T* (ABS(C0M(J+1) )-8192 . ) +ABS (ARGTAB ( 1+1 ) ) 

IF   (Y)  310,310,290 

C0M(J+1)=SIGN(Y,C0M(J+1)) 

GO  TO  170 

K=18 

GO  TO  320 
K=20 

CALL  ERROR  (K) 
RETURN 


***  (=THRU)  IGNORE.  INCREM. 
HAVE  CORRESPONDING  *** 


OR  RESTORE  MAY  OR  MAY  NOT 


IF(ARGTAB(I).EQ.(-1.)) 

J=J+1 

GO  TO  190 


1  =  1+1 


NESTED  PERFORMS  UP  TO  EIGHT  LEVELS  ARE  ALLOWED 
CURRENT    LEVEL      IS  STORED     IN  LEVEL 


INDEX(1, LEVEL) 
INDEX(2, LEVEL) 
INDEX(3, LEVEL) 
INDEX(4, LEVEL) 
INDEX(5, LEVEL) 
INDEX(6, LEVEL) 


CONTAINS  LOCATION  OF  COMMAND  AT  ARGl  (FIRST) 
CONTAINS  RUNNING  INDEX    FROM  ARGl  TO  ARG2 
CONTAINS  LOCATION  OF  COMMAND  AT  ARG2 (LAST) 
CONTAINS  THIRD      ARG  (REPEAT  COUNT) 
CONTAINS  CURRENT  LEVEL  COUNTER     (1  TO  ARG3) 
CONTAINS  STATEMENT  NUMBER  OF  STATEMENT  CURRENTLY 
BEING  EXECUTED. 


IF  (NARGS-3)  360,400,390 
IF  (NARGS-1 )  390,370,380 

SECOND  ARG  MISSING, MAKE  SAME  AS  FIRST  ARG 

IARGS(2)=IARGS(1) 
KIND(2)=KIND(1) 

THIRD  ARG  MISSING,  SET  TO  INTEGER  1 

IARGS(3)=1 

KIND(3)=0 

GO  TO  410 

CALL  ERROR  (10) 

GO  TO  500 

IF  (KIND(3) .EQ.0.AND.IARGS(3) .GT.O)  GO  TO  410 
CALL  ERROR  (3) 
GO  TO  500 
DO  450  1=1,2 

IF  (KIND (I ) .EQ.O)  GO  TO  420 
IARGS(I)=10.*ARGS(I)+.5 
GO  TO  430 


REP1180 
REP1190 
REP1200 
REP1210 
REP1220 
REP1230 
REP1240 
REP1250 
REP1260 
REP1270 
REP1280 
REP1290 
REP1300 
REP1310 
REP1320 
REP1330 
REP1340 
REP1350 
REP1360 
REP1370 
REP1380 
REP1390 
REP1400 
REP1410 
REP1420 
REP1430 
REP1440 
REP1450 
REP1460 
REP1470 
REP1480 
REP1490 
REP1500 
REP1510 
REP1520 
REP1530 
REP1540 
REP1550 
REP1560 
REP1570 
REP1580 
REP1590 
REP1600 
REP1610 
REP1620 
REP1630 
REP1640 
REP165* 
REP1660 
REP1670 
REP1680 
REP1690 
REP1700 
REP1710 
REP1720 
REP1730 
REP1740 
REP1750 
REP1760 
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420 
430 


440 
450 

460 


C 
C 
C 

470 

C 
C 
C 


480 
490 


500 


IARGS ( I )=10*IARGS (I ) 

IF  (IARGS(I) .GT.NSTMTH)  GO  TO  440 

IARGS(I)=LOCATE(IARGS(I) ) 

IF  (IARGS(I) .GT.O)  GO  TO  450 

CALL  ERROR  (13) 

GO  TO  500 

CONTINUE 

IF  (LEVEL. LT. 8)  GO  TO  460 
CALL  ERROR  (19) 
GO  TO  500 

IF  (IARGS (2) .LT.IARGS(l) )  CALL  ERROR  (3) 

IF  (NERROR.NE.O)  GO  TO  500 

LEVEL=LEVEL+1 

INDEX(1,LEVEL)=IARGS(1) 

INDEX(3,LEVEL)=IARGS(2) 

INDEX(4,LEVEL)=IARGS(3) 

INDEX(5,LEVEL)=0 

OUTER  LOOP 

INDEX (5, LEVEL )=INDEX (5, LEVEL) +1 

IF  (INDEX (5 , LEVEL) . LE . INDEX (4 , LEVEL) )  GO  TO  480 

FINISHED  OUTER  LOOP,  REDUCE  LEVEL  BY  1 

LEVEL=LEVEL-1 
IF  (LEVEL. GT.O)  GO  TO  490 
RETURN 

INDEX (2 , LEVEL )=INDEX (1 , LEVEL) 
I2=INDEX(2,LEVEL) 

IF  (12. GT.INDEX(3, LEVEL))  GO  TO  470 

INDEX(6,LEVEL)=C0M(I2) 

K=C0M(I2+1) 

INDEX(2,LEVEL)=INDEX(2,LEVEL)+K 

L2=C0M(I2+2) 

Ll=L2/64 

NARGS=L2-64*L1 

L2=Ll/64 

L1=L1-64*L2 

CALL  EXPAND  (K-2 ,C0M(I2+3) ) 
RETURN 

IJSWT=-IJSWT 

RETURN 

END 


REP1770 
REP1780 
REP1790 
REP1800 
REP1810 
REP1820 
REP1830 
REP1840 
REP1850 
REP1860 
REP1870 
REP1880 
REP1890 
REP1900 
REP1910 
REP1920 
REP1930 
REP1940 
REP1950 
REP1960 
REP1970 
REP1980 
REP1990 
REP2000 
REP2010 
REP2020 
REP2030 
REP2040 
REP2050 
REP2060 
REP2070 
REP2080 
REP2090 
REP2100 
REP2110 
REP2120 
REP2130 
REP2140 
REP2150 
REP2160 
REP2170 
REP2180 
REP2190 
REP2200 
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^IIRROHTTMF  RFSFT 

Klj 

i  n 
J.  u 

p 

VFRSTON     5   00           RFSFT  5/15/70 

?  n 

COMMON  /BLOCRC/  NRC , RC  ( 12600 ) 

RES 

COMMON  /BLOCKD /  IARGS(100) , KIND (100) ,ARGTAB (100) , NRMAX ,NR0W,NC0L ,NRES 

An 

1ARGS  VWXYZ(ft^  NERROR 

X  HJ\  w  J  /  V  If  A  I  im  \  O  )  f  II  t-  IVi\  vn 

RFS 

l\LJ 

^  n 

nTMFNSTON  ARGSHOO} 

RFS 

I\LJ 

An 

FnilTVAIFNPF    f  ARG^M  ^  Rf/IKflin 

RFS 

7n 

TOMMON   /BLOfKE/  NAME (4^   LI  L2  ISRFLG 

V«i  V  llllf  IV/ 11      /  UUU  w!\U  /      11  H  If  IL.  \  "  ^    r  LX  (  L4  (  1  JIM    L.  V3 

RFS 

l\  L.  J 

o  u 

IFfNARGS  EO  1}   T  F  f  L2— 2  ^   25  20  40 

RES 

1\  L-  «J 

ft  ^ 

K=10 

RES 

Qn 

i  n 
1  u 

PALI   FRROR  (K\ 

RFS 

l\LJ 

i  nn 

J.UU 

o  n 
L  u 

RETURN 

l\  L.  l  U  l\  11 

RFS 

1 1  n 

1 1  u 

p 

RESET  NRMAX 

RFS 

l\LJ 

l  7  n 

TF    (KTNfWn    NF   ft  *    T  ARGS  f  "M  —  ARGS  f  *M 

IT       ^rXJLIlls^xJ   .I1L..U/      IHI\gj  \  1  )  — M  rv  VI  J  ^  X  / 

RFS 

i  in 

i.  J  V 

IF   f  I ARGS  f  1  ^  GE  0  AND  IARGSm   LE  NROUh  GO  TO  30 

RES 

r\  l.  j 

1 4n 

K=3 

RES 

i  ^  n 

GO  TO  10 

RES 

i  An 

in 

NRMAX-I ARGS  ( 1 ^ 

RES 

f\  L.  <J> 

i  7n 

cc\  to  ?ft 

RFS 

i  ft  n 

r 

RESET  V,W,X,Y,Z 

RES 

190 

X  7  VI 

40 

"T  VI 

IF  (KIND(l) .EQ.0)  ARGS(1)=IARGS(1) 

RES 

?nn 

VWXYZ(L2-2)=ARGS(1) 

RES 

5 1  n 

GO  TO  20 

RES 

o  o  n 

END 

RES 

230 
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c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 


10 


c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 

20 


30 


SUBROUTINE  RFORMT  (X , N , NS ,NW , ND , NX , XVAL , ARRAY , NB , NC ) 

VERSION    5.00         RFORMT  5/15/70 

WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS .  4/18/69. 

REWRITE  AND  COMBINING  OF  FXFARG (2 / 1 /69 )  AND  FXF0RM(2 /7 /69 ) . 
FLOATING  FORMAT  1PE  NW.NS-1  IS  GIVEN  IF  N  LT  0  AND  NX  LT  0 . 
FIXED  FORMAT  F  NW.ND  IS  GIVEN  IF  N  GE  0  AND  NX  LT  0 .     SET  NS=8. 
PERIOD  NOT  PRINTED  IF  NDECS=0 
FXFARG  SET  ***  XVAL=X  (OR  ANY  REAL  VARIABLE) 

ARRAY=A  (OR  ANY  DIMENSIONED  VECTOR) 

NBLANK=0  (OR  ANY  OTHER  INTEGER) 

INPUT  ***  X,  N,  NSIGDS,  NWMAX. 

OUTPUT  ***  NWIDTH ,  NDECS  . 
FXFORM  SET  ***  X=X(OR  ANY  REAL  VARIABLE) 

N=l  (OR  ANY  INTEGER) 

NWMAX=0 

INPUT  ***  XVAL,  NSIGDS,  NWIDTH,  NDECS,  NBLANK. 
OUTPUT  ***  ARRAY 

$  $  $  $  $ 

NUMBER  IS  CENTERED  IF  NC=1  AND  NOT  CENTERED  IF  NC=0 (RIGHT  JUST'D 
THIS  REVISION  WRITTEN  10/09/69 
COMMON  /ABCDEF /  L(48) 
DIMENSION  X(l),  ARRAY (1) ,  C(10) 

EQUIVALENCE  (C(1),L(1)),   (BLANK , L (45 )) ,   (PERIOD ,L (38) ) ,  (CPLUS,L( 

10)),   (CMINUS,L(39)) ,   (CASTER , L (41 ) ) 

DOUBLE  PRECISION  Z 

NSIGDS=MIN0(8,NS) 

NSIGDS=MAX0(1, NSIGDS) 

IF   (NX)  50,60,20 
***** 

FXFARG  SUBROUTINE 

INPUT  FOR  THE  SUBROUTINE  FXFORM.     NWMAX  IS  THE  MAXIMUM  ALLOWABLE 
VALUE  OF  NWIDTH.  X  MUST  BE  DIMENSIONED  AND  N  IS  ITS  LENGTH. 
NWMAX  MUST  BE  GREATER  THAN  NSIGDS  PLUS  FOUR 
NWIDTH  =  MIN (MMAX-MMIN+NSIGDS+2 , NWMAX) 

NDECS=NSIGDS-MMIN-1,  NDECS=MIN0 (MAXO (NDECS ,NSIGDS+2 ) ,NWMAX-3 ) ,  IF 
NWIDTH  EXCEEDS  NWMAX. 

IF  NSIGDS  GT  8,  IT  IS  SET  =  TO  8,  IF  LT  1  SET  =  TO  1. 

REFERENCE  ***  SEL  NOTE  N-68-3,  SEPTEMBER,  1968. 

WRITTEN  BY  DAVID  HOGBEN,  SEL,  NBS.      2/  1/69. 
*  *  *  *  * 

NWMAX=MAXO (NSIGDS+5 ,NX) 

Y=ABS(X(1)) 

IF  (Y.LE.O.)  Y=1.0 

Y1=Y 

Y2=Y 

IF  (N.LT.l)  N=l 

DO  30  1=1, N 

Y=ABS(X(I)) 

IF  (Y.LE.O.)  Y=1.0 

IF  (Y.LT.Y1)  Y1=Y 

IF  (Y.GT.Y2)  Y2=Y 

CONTINUE 

MMIN=FL0G10(Y1) 

IF  (Yl.LT.l.)  MMIN=MMIN-1 

MMAX=FL0G10(Y2) 

IF  (Y2.LT.1.)  MMAX=MMAX-1 

Z=Y1 

LL=Z*10.D0**(NSIGDS-MMIN)+5.0D0 


RFO 
RFO 
RFO 
RFO 
RFO 
RFO 
RFO 
RFO 
RFO 


10 
20 
30 
40 
50 
60 
70 
80 
90 


RFO  100 
RFO  110 
RFO  120 
RFO  130 
RFO  140 
RFO  150 
RFO  160 
RFO  170 
RFO  180 
RFO  190 
RFO  195 
RFO  197 
RFO  200 
RFO  210 
4RF0  220 
RFO  230 
RFO  240 
RFO  250 
RFO  260 
RFO  270 
RFO  280 
RFO  290 
RFO  300 
RFO  310 
RFO  320 
RFO  330 
RFO  340 
RFO  350 
RFO  360 
RFO  370 
RFO  380 
RFO  390 
RFO  400 
RFO  410 
RFO  420 
RFO  430 
RFO  440 
RFO  445 
RFO  450 
RFO  460 
RFO  470 
RFO  480 
RFO  490 
RFO  495 
RFO  500 
RFO  510 
RFO  520 
RFO  530 
RFO  540 
RFO  550 
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IF  (LL.GE.10** (NSIGDS+1) )  MMIN=MMIN+1  RFO  560 

IF  (LL.LT.10**NSIGDS)  MMIN=MMIN-1  RFO  570 

Z=Y2  RFO  580 

LL=Z*10.D0**(NSIGDS-MMAX)+5.0D0  RFO  590 

IF  (LL.GE.10**(NSIGDS+1))  MMAX=MMAX+1  RFO  600 

IF  (LL.LT.10**NSIGDS)  MMAX=MMAX-1  RFO  610 

NDECS=NSIGDS-MMIN-1  RFO  620 

NDECS=MAXO(0,NDECS)  RFO  630 

NWIDTH=MMAX+3+NDECS  RFO  640 

IF   (MMAX.LT.O)  NWIDTH=NDECS+2  RFO  650 

IF  (NWIDTH.LE.NWMAX)  GO  TO  40  RFO  660 

N0ECS=MAX0(NDECS,NSIGDS+2)  RFO  670 

NDECS=MINO (NDECS, NWMAX-3)  RFO  680 

NWIDTH=NWMAX  RFO  690 

IF  (NDECS.LT.O)  NDECS=0  RFO  700 

ND=NDECS  RFO  710 

NW=NWIDTH  RFO  720 

RETURN  RFO  730 

*****  RFO  740 

FXFORM  SUBROUTINE  RFO  750 

SUBROUTINE  FXFORM  ALLOWS  PRINTING  OF  REAL  NUMBERS  X  IN  FIXED  RFO  760 
FORMAT  WITH  DECIMAL  POINT  IN  CONSTANT  POSITION.  NWIDTH  =  WIDTH  OFRFO  770 
FIELD,  NDECS  =  NUMBER  OF  PLACES  TO  RIGHT  OF  DECIMAL  POINT,  X  IS      RFO  780 

THE  NUMBER,  ARRAY  IS  THE  VECTOR  WHERE  X  IS  RETURNED  TO  BE  PRINTED  RFO  790 

ACCORDING  TO  A  FORMAT,  NSIGDS  =  NUMBER  OF  DIGITS  GIVEN  WITH  BLANKSRFO  800 

ON  THE  RIGHT,  NBLANK  IS  THE  NUMBER  OF  BLANKS  TO  BE  PUT  ON  THE  RFO  810 
LEFT  OF  THE  FIELD.     IF  X  IS  TOO  LARGE  OR  TOO  SMALL  IT  IS  RETURNED  RFO  820 

AS  A  FLOATING  POINT  NUMBER.  ARRAY  MUST  BE  DIMENSIONED.  RFO  830 
A  PERIOD  IS  NOT  GIVEN  IF  X  IS  GREATER  THAN  OR  EQUAL  TO  10**NSIGDS  RFO  840 

ZERO  IS  WRITTEN  0.  RFO  850 

IF  NDECS=NWIDTH ,  BLANKS  ARE  RETURNED  RFO  860 

SUBROUTINE  MAY  BE  USED  IN  CONJUCTION  WITH  SUBROUTINE  FXFARGS .  RFO  870 

IF  NSIGDS  GT  8,  IT  IS  SET  =  TO  8,  IF  LT  1  SET  =  TO  1.                       RFO  880 

NWIDTH  IS  ADJUSTED  IF  NECESSARY  SO  THAT  IT  IS  GE  NDECS+2 ,                RFO  890 

GE  NSIGDS+2  IF  FIXED  AND  GE  NSIGDS+5  IF  FLOATING                               RFO  900 

REFERENCE  ***  SEL  NOTE  N-68-3 ,  SEPTEMBER,  1968.  RFO  910 

WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS .      2/  7/69.                                     RFO  920 

*****  RFO  930 

NWIDTH=NW  RFO  940 

GO  TO  70  RFO  950 

NWIDTH=MAXO(NW, NSIGDS+2)  RFO  960 

NDECS=MAX0(0,ND)  RFO  970 

IF  (NWIDTH. LT. NDECS)  NWIDTH=NDECS+2  RFO  980 

NB=MAXO(0,NB)  RFO  985 

IF(NC.NE.O)  NC=1  RFO  990 

NBLANK=NB-(NB/2 ) *NC  RFO  995 

MF=0  RF01000 

Y=ABS(XVAL)  RF01010 

NDIFF=NWIDTH-NDECS  RF01020 

NWMAX=NWIDTH+NBLANK  RF01030 

NPONE=NDIFF+NBLANK  RF01040 

IEND=NWIDTH+NB  RF01045 

DO  90  1=1 , IEND  RF01050 

ARRAY ( I )=BLANK  RF01060 

IF  (NDECS. EQ. NWIDTH)  RETURN  RF01070 

IF  (Y.GT.O.)  GO  TO  110  RF01080 

XVAL=0.  IS  SPECIAL  CASE  UNLESS  FIXED  OR  FLOATING  RF01090 

IF  (NX.GE.O)  GO  TO  100  RF01100 

FIXED  RF01110 
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W=0 

RF01120 

GO  TO  130 

RF01130 

100 

IF  (NDECS.NE.O)  ARRAY (NPONE)=PERIOD 

RF01140 

ARRAY(NP0NE-1)=C(1) 

RF01150 

RETURN 

RF01160 

110 

M=FLOG10(Y) 

RF01170 

IF  (Y.LT.l.)  M=M-1 

RF01180 

Z=Y 

RF01190 

Z  =  Z*10.D0** (NSIGDS-M) 

RF01193 

XI  =  Z 

RF01196 

LL1  =  XI 

RF01200 

X2  =  Z  -  DBLE(Xl) 

RF01205 

LL2  =  X2 

RF01210 

LL  =  LL1  +  LL2  +  5 

RF01215 

IF  (LL.LT.10**(NSIGDS+1))  GO  TO  120 

RF01220 

M=M+1 

RF01230 

LL=LL/10 

RF01240 

GO  TO  130 

RF01250 

120 

IF  (LL.GE.10**NSIGDS)  GO  TO  130 

RF01260 

Rft=M-l 

RF01270 

LL=10*LL 

RF01280 

130 

IF  (NX.EQ.O)  GO  TO  170 

RF01290 

IF  (N.LT.O)  GO  TO  180 

RF01300 

C 

FIXED 

RF01310 

IF  (M.LT. NDIFF-2)  GO  TO  150 

RF01320 

IF  (M.EQ .NDIFF-2 .AND .XVAL .GE . 0 . )  GO 

TO 

150 

RF01330 

NSIGDS=MAX0(0,NWIDTH-5) 

RF01340 

IF  (NSIGDS.GT.O)  GO  TO  180 

RF01350 

C 

PUT  IN  ASTERISKS 

RF01360 

DO  140  I=1,NWIDTH 

RF01370 

IRVSP=I+NBLANK 

RF01375 

140 

ARRAY (IRVSP)=CASTER 

RF01380 

RETURN 

RF01390 

150 

NSIGDS=MINO (8 ,NDECS+M+1 ) 

RF01400 

NSIGDS=MAXO(0,NSIGDS) 

RF01410 

LL=(LL-5)/(10**(8-NSIGDS))+5 

RF01420 

IF  (NSIGDS.GT.O)  GO  TO  170 

RF01430 

IF  (XVAL. LT. 0.0)  ARRAY (NPONE-1 )=CMINUS 

RF01440 

DO  160  I=NPONE,NWMAX 

RF01450 

160 

ARRAY(I)=C(1) 

RF01460 

ARRAY (NPONE)=PERIOD 

RF01470 

IF(NDECS+1.EQ. (-M) . AND . LL .GT . 10 )  ARRAY (NWMAX ) 

=C(2) 

RF01480 

RETURN 

RF01490 

170 

MREAL=0 

RF01500 

IF  (M.GE .NSIGDS-1-NDECS .AND .M.LT .  NDIFF- 

-2)  GO 

TO  190 

RF01510 

IF  (M. EQ. NDIFF-2. AND. XVAL. GT. 0. )  GO 

TO 

190 

RF01520 

C 

FLOATING 

RF01530 

180 

MREAL=M 

RF01540 

M=0 

RF01550 

MF=1 

RF01560 

Y=Y*10.**(-MREAL) 

RF01570 

190 

IF  (M.LT.NSIGDS. AND. NDECS.NE.O)  ARRAY (NPONE )= 

PERIOD 

RF01580 

NINT=NP0NE-1-M 

RF01590 

IF  (M.LT.O)  NINT=NINT+1 

RF01600 

NEND=NINT+NSIGDS-1 

RF01610 

IF  (M.GE.O.AND.M.LT.NSIGDS-1)  NEND=NEND+1 

RF01620 

DO  200  J=NINT , NEND 

RF01630 

I=NEND+NINT-J 

RF01640 

IF  (I. EQ. NPONE)  GO  TO  200 

RF01650 
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II         II      J  1  A 

LL=LL / 10 

A  A  A.  *l    y    y  A 

RF01660 

AO  HI       ||Af\    /II  TAX 

NN=MOD (LL , 10) 

A  P  A  ^    y  ^*  f\ 

RF01670 

t  rt  n  i  \y  /  t  \     a  /  hi  hi  i\ 

ARRAY ( I )=C (NN+1 ) 

RF01680 

200 

a  AlIT  T  hi  i  i  r* 

CONTINUE 

RF01690 

T  i*-        ,  hi  A      A  f\      f\  \       A  A      X  A  AAA 

IF   (MF.EQ.O)  GO  TO  220 

RF01700 

c 

m  it    Til    runAnrmT    r~  a  a    r*  i  a  ax  t  hi  a    a  a  t  ti  x    hi  i  i  tin  r*  a 

PUT  IN  EXPONENT  FOR  FLOATING  POINT  NUMBER 

RF01710 

t  r—        /  kllllT  l\TII      A  A      hi  A  T  A  A.  A                   AA      T  A  ATA 

IF  (NWIDTH .GE .NSIGDS+5 )  GO  TO  210 

RF01720 

hi  111  T  ff\  X  1  1      hi  A  T  A  A  A  f 

NWIDTH=NSIGDS+5 

RF01730 

PA     T A     a  a 

GO  TO  80 

A  1™  A  1  "T  A 

RF01740 

O  1  A 

210 

T  f~      /  hlA  C  A  1       IT     A  \      AODAV  /klTKin     1  \      A  fed  T  fcl  1  1  c 

lr    (MKLAL . L 1 . 0 )  AKKAY(NLND+l)=LMINUb 

A  r  A  t  ■?  p  n 

RF01750 

T  r       /  Itn  PAI       AC      A\       AHDAU  /klTkin      1   \       A  A  1    1  1  A 

IF   (MREAL.GE.0)  ARRAY (NEND+1 )=CPLUS 

A  A  A  1  ^  /  A 

RF01760 

11D  r  A  1    A      T  A  D  C  /  hJD  C  A  1  \ 

MKhALA=l Abb (MKLAL ) 

RF01770 

11 1      h  in  r  Al    A   /  1  A 

M1=MKLALA / 10 

A  l~  A  1  T  A  A 

RF01780 

a  a  a     hlA  H  /  IAD  C  Al    A      1  A  \ 

M2=M0D (MREALA , 10 ) 

A  r-  A  1  T  A  A 

RF01790 

AKKAY (NbNU+2 )=L (Ml+1 ) 

D  C  A 1  AAA 

RF01800 

ARRAY (NEND+3 )=C (M2+1 ) 

A  I™  A  1  AT  A 

RF01810 

AAA 

220 

?  ir     /  uii  i  i      it    a        a  hi  n    hi    rr    a  \      inniu  /iitiit    i\     a  hi  t  hi  i  i  a 

IF   (XVAL . LT . 0 . . AND . M . GE . 0 )  ARRAY (NINT-1 )=CMINUS 

A  i™  A  1  AAA 

RF01820 

t  f~     /  vi  / 1  i      ix    a        i  tm    hi    ix    a  \      inni\/  /  tinnur    i\     a  hi  t  hi  1 1  c 

IF   (XVAL . LT . 0 .. AND . M. LT . 0 )  ARRAY (NP0NE-1 )=CMINUS 

A  A  A  T    A  A 

RF01830 

t  r  /  II     Al~       /      t    \   \          AA     XA  AiCA 

IF (M.GE . (-1 ) )     GO  TO  240 

A  A  A  1    A  A  A 

RF01840 

T  1       hi  A  A  hi  r*  1 

I 1=NP0NE+1 

n            i  A  IT  A 

RF01850 

T  A     hi  T  hi  x  ^ 

I 2=NINT-1 

A  I-  /"\  n    y^  y  ^\ 

RF01860 

T\f\      A  *>  A       T       TT  TA 

DO  230  1=11,12 

A  r~  A  1  ATA 

RF01870 

230 

AAAA\//T\       A  /  1  \ 

ARRAY(I)=C(1) 

A  A  A  ^  AAA 

RF01880 

A  r*  X  1  1  A  hi 

RETURN 

A  A  A  1  AAA 

RF01890 

A 

C 

ni  IT      T  hi     hi  A  hi     CTAhlTi~TAAhlX  TrnftT 

PUT  IN  NON-SIGNIFICANT  ZEROS 

nrrti aaa 

RF01900 

240 

T  A        /hi     IX      11  f  T  AAA      An      hlf"*      Hi"-      f\  \       htti  inn 

IF  (M. LT . NSIGDS .OR . MF . NE . 0 )  RETURN 

ft  A  A  ^  a  n  A 

RF01910 

T  T        hi  T  hi  X      II  (*  T  A  A  A 

I 1=NINT+NSIGDS 

n  A  A  1  A  A  A 

RF01920 

T  *\      a I  pi  An  r"  n 

I 2=NP0NE-1 

ft  ^  A  t  a  a 

RF01930 

A  A            f"  A       T        T  T        T  A 

DO  250  1=11,12 

A  1"  A  1  A  A  A 

RF01940 

250 

AAAA\//T\       A  /  •»  \ 

ARRAY(I)=C(1) 

A  r"  A  1  A  IT  A 

RF01950 

RETURN 

RF01960 

END 

RF01970 
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c 
c 
c 
c 


10 
20 


30 
40 
C 

50 
60 

70 


SUBROUTINE  RNDOWN 

VERSION    5.00         RNDOWN  5/15/70 

COMMON  /BLOCKC/  KIO , I NUN IT , I  SCR AT ,KBDOUT ,KRDKNT ,LLIST 

COMMON  /BLOCKX/  INDEX (6 , 8 ), LEVEL 


IF  AN  ERROR 
OUT  EXACTLY 


IS  MADE  IN  A  STORED  STATEMENT, 
WHEN  AND  WHERE  IT  OCCURRED. 


/10. 


THIS  ROUTINE  PRINTS 


A=FLOAT ( INDEX (6 , LEVEL) 
WRITE  (ISCRAT,50)  A 
N=LEVEL-1 
IF  (N)  40,30,20 
A=FLOAT (INDEX (6 ,N) ) /10. 

WRITE  (ISCRAT,60)  INDEX (5 ,N+1 ) , INDEX (4 ,N+1 ) ,A 

N=N-1 

GO  TO  10 

WRITE  (ISCRAT,70)  INDEX  (5 , 1 ) , INDEX (4 , 1 ) 
RETURN 


FORMAT 
FORMAT 

1.23X) 
FORMAT 

IT.  ,32X) 
END 


(31H  IN  COMMAND  AT  STATEMENT  NUMBER , F6 . 1 ,47X) 
(10H  CYCLE  N0.,I4,3H  0F,I4,24H  OF  PERFORM  AT  STATEMENT 


(10H  CYCLE  N0.,I4,3H  0F.I4.31H  OF  EXTERNAL  PERFORM 


RND  10 

RND  20 

RND  30 

RND  40 

RND  50 

RND  60 

RND  70 

RND  80 

RND  90 

RND  100 

RND  110 

RND  120 

RND  130 

RND  140 

RND  150 

RND  160 

RND  170 

RND  180 

RND  190 

RND  200 

1RND  210 

RND  220 

STATEMENRND  230 

RND  240 

RND  250 


F6 


SUBROUTINE  RNJBK  (RNO  ,N START .NFINSH) 

RNJ 

10 

c 

VERSION    5.00         RNJBK  5/15/70 

RNJ 

20 

DATA  M,FLM/8192,8192./ 

RNJ 

30 

c 

8192=2**13 

RNJ 

40 

c 

JB  KRUSKAL  (1969)  ACM,  12,  93-94. 

RNJ 

50 

c 

RNJ 

60 

c 

RETURNS  RANDOM  NUMBER  (0,1)  IN  RNJBK. 

RNJ 

70 

c 

SET  NSTART=1  TO  START  AT  BEGINNING,  OTHERWISE  PREVIOUS  NFINSH. 

RNJ 

80 

c 

RETURNS  NFINSH  FOR  LAST  NUMBER  GENERATED. 

RNJ 

90 

c 

WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS .  3/24/69. 

RNJ 

100 

c 

jf:  #  $  af:  % 

RNJ 

110 

K=NSTART 

RNJ 

120 

DO  10  1=1,3 

RNJ 

130 

10 

K=M0D(5*K,M) 

RNJ 

140 

RNO=FLOAT(K) /FLM 

RNJ 

150 

NFINSH=K 

RNJ 

160 

RETURN 

RNJ 

170 

END 

RNJ 

180 
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bUdKUUIlNt  KHK1NI 

RPR 

10 

c 

VERSION    5.00         RPRINT  5/15/70 

RPR 

20 

p 

*********************  ********************=*=****s(=*************=(=****=*:^pj^ 

30 

p 
C 

RPRINT  COLS  ++,  ++,   ...  ++  (MAXIMUM  OF  50  COLS)    (NO  OF  SD  IS  8) 

RPR 

A  A 

40 

p 

RPRINT  COLS  ++,  ++,   ...  ++  WITH  **  SIGNIFICANT  DIGITS   (49  COL  MAX) RPR 

C  A 

50 

p 
C 

DDD  T  KIT    mi  C     ■  ■                 >i     1UTTU    **    Cn                   1 MUIMAY  —  1  1       NUITrtTUIiMBI  AMtf 
KrK  1  It  1    l>ULj    ++       ..    ++   Wl  In           jll  ,     ...     \r%  WIVIA  A=l  3  ,    n  W 1  U  1  n+NDLAIMN= 

1 C \ DDD 

Id )  Kr  K 

60 

p 

c 

DDD 

KrK 

T  A 

70 

p 

ddrtwt  **  rni  q    rni  ■  ■  u/ttu        cn          ^nu/may—??     mri  amk  ->  \ 

Kr K 1 N 1            lULj  ,                    Wl  1  n            D  U     ...     yn  WIVIA  K=L  c  ,    NDLANft.=.?  ) 

DDD 
KrK 

A  A 

80 

p 
C 

PPRTMT    **    mi  C       ,  .    WITH           Cn    AKin    MUUMAY   _                          ^WRI  AN  If—  1  \ 
K  r  K  1  N  1            1/ULj  ,    ++    Wl  1  n     ,,    jU    AN  U    v%  nMA  A    —    ,  ,  ,     ...        \  HDL  MWI\=  j  ) 

DDD 
KrK 

90 

p 

DDD  I  wt   **   rni  C      i  i_  uittu         cn  MUIMA  Y         mri  auk 

Krl\lli  1            L>UL  j  ,    ++    Wl  in     ,  ,    Z)V    N  YtlrlAA    ,,    NDLAINIV     ,,  ... 

DDD 

KrK 

1  A  A 

100 

p 

RPR 

1  T  A 

110 

p 

FLOATING  1PEW.D  IS  OBTAINED  IN  LAST  TWO  OPTIONS  IF  NWMAX=0 . 

RPR 

1  A  A 

120 

p 

W=NSIGDS+5  AND  D=NSIGDS-1 

RPR 

T  1  A 

130 

p 

FIXED  FW.D  IS  OBTAINED  IN  LAST  TWO  OPTIONS  IF  NWMAX  LT  0. 

RPR 

1  it  A 

140 

p 

W=-NWMAX      AND  D=NSIGDS 

RPR 

1  C  A 

150 

C 

IW  IS  OBTAINED  IN  LAST  TWO  OPTIONS  IF  NSIGDS=0  AND  NWMAX=-W. 

RPR 

160 

p 

1  T  A 

170 

p 

REPLACES  TRAILING  ZEROS  BY  BLANKS  IF  COUNT  LT  NRMAX 

RPR 

1  O  A 

180 

p 

IF  COLUMN  CONTAINS  ALL  ZEROS  AND  FIRST  ARGUMENT  IS  A  COLUMN  NUMBERRPR 

1  O  A 

190 

p 

NO  COLUMN  HEADING  IS  GIVEN 

RPR 

o  a  a 
200 

p 

IF  FIRST  ARGUMENT  IS  NOT  A  COLUMN  NUMBER  (1)  NO  HEADING  IF  WIDTH  RPR 

A  1  A 

210 

LESS  THAN  6,   (2)  COL  NO  IF  6  LE  WIDTH  LT  12,   (0)  COLUMN  XXX. 

IFRPR 

AAA 

Z20 

p 

WIDTH  GREATER  THAN  OR  RQUAL  TO  12. 

RPR 

A  O  A 

230 

p 

IF  NUMBER  IS  FLOATED  ASTERISK  IS  PUT  TO  RIGHT  OF  FIELD. 

RPR 

1  A  A 

240 

p 

NUMBERS  ARE  PRINTED  IN  BLOCKS  OF  5  IF  NRMAX  IS  LESS  THAN  49. 

RPR 

OCA 

250 

C 

WRITTEN  BY  DAVID  HOGBEN ,  5EL,  NBS .  4/17/69. 

RPR 

260 

P 

Vj 

#  £  $  Z-  $      *  *  $  $  #      $  $      $  +  %  *  #  *  *  *  *  :Je  jfc  rfc  #  ^  ^  ^  *  ^  ^  ^  #  ^  ^  ^  ^  +  ^  ^  ^  ^  *  ^  *  *  *  *  *  *  ^:  *  ^  i|(  *  *  4;  *  *  *  +  *  *  p 

o  7  n 

COMMON  /ABCDEF /  L(48) 

RPR 

2oU 

COMMON  /BLOCRC/  NRC  ,RC  (12600) 

RPR 

9  0ft 
i.  7  U 

COMMON  /BLOCKD /  IARGS(IOO) , KIND (100) ,ARGTAB (100) , NRMAX ,NR0W,NC0L ,NRPR 

JUU 

1ARGS,VWXYZ(8) ,NERR0R 

RPR 

J 10 

DIMENSION  ARGS(IOO) 

RPR 

1 9  n 
>  c  U 

EQUIVALENCE  (ARGS ( 1 ). RC  ( 12501 ) ) 

RPR 

COMMON  /BLOCKE/  NAME (4) ,L1 ,L2 , ISRFLG 

RPR 

i  a  a 
.3  4U 

COMMON  /SCRAT/  NS ,NS2 ,A (13500) 

RPR 

COMMON  /HEADER/  NOCARD (80 ) , ITLE (60 , 6 ) , LNCNT , I  PR  INT , NPAGE , IPUNCH 

RPR 

1  L  A 

360 

COMMON  /FMAT /  IFMTX (6 ) , IOSWT , IFMTS (6 ) , LHEAD (96 ) 

RPR 

370 

p 

******************************************************************ppp 

Oflft 

j  dU 

DIMENSION  NWIDTH(IOO) ,  NDECS(IOO),  NBLANK ( 100 ) ,  IRGS(IOO),  NCOUNT(RPR 

lQft 

1100),  NWMAX(IOO),  NSIGDS(IOO) ,  AL(48),  NF(IOO),  NWM(IOO) 

RPR 

Ann 

EQUIVALENCE  (NWIDTH ( 1 ) , A ( 1001 ) ) ,   (NDECS ( 1 ) , A ( 1101 ) ) ,   (NBLANK (1) , A (RPR 

J  l  ft 

11201)),   (IRGS(l) ,A(1301) )  ,   (NCOUNT(l) ,A(1401) )  ,   (NWMAX (1 ), A (1601 )) RPR 

Aon 

2,    (NSIGDS(l) ,A(1701) ) ,   (AL ( 1 ) , L ( 1 ) ) ,   (NF ( 1 ) , A ( 1801 ) ) ,   (NWM(1 ) , A ( 19RPR 

Aid 

301)) 

RPR 

A  A  A 

440 

p 
C 

$  *  *  ♦  ♦ 

RPR 

4d0 

p 

c 

IRGS(I)  NEEDED  FOR  HEADS  BECAUSE  CHKCOL  IS  USED 

RPR 

A  L  A 
460 

p 

c 

LINES  20  TO  70  DO  ERROR  CHECKING 

RPR 

A  7  A 

IF  (L1.NE.6)  GO  TO  20 

RPR 

A  Q  A 

NARGS=NARGS-1 

RPR 

IF  (KIND(l) .EQ.l)  GO  TO  50 

RPR 

enn 
DUU 

IF  (IARGS(l) .LE .0 .OR . IARGS (1) .GT.NROW)  GO  TO  60 

RPR 

cin 

NRJ=IARGS(1)-1 

RPR 

con 

3  C  U 

IF  (NARGS.LT.l)  GO  TO  30 

RPR 

C  7  ft 

DO  10  I=1,NARGS 

RPR 

KIND (I )=KIND ( 1+1) 

RPR 

K^n 

IARGS (I )=IARGS ( 1+1 ) 

RPR 

10 

ARGS(I)=ARGS(I+1) 

RPR 

C7  ft 

0  A 

20 

IF  (NARGS.GT.O)  GO  TO  40 

RPR 

RAO. 

30 

CALL  ERROR  (10) 

RPR 

590 

274 


GO  TO  400 

RPR  600 

40 

IF  (NRMAX.GT.O)  GO  TO  70 

RPR  610 

CALL  ERROR  (9) 

RPR  620 

GO  TO  400 

RPR  630 

50 

CALL  ERROR  (3) 

RPR  640 

GO  TO  400 

RPR  650 

60 

CALL  ERROR  (11) 

RPR  660 

GO  TO  400 

RPR  670 

C 

ALL  ARGUMENTS  ARE  INTEGERS. 

RPR  680 

70 

NPAR=1 

RPR  690 

IF  (KIND (1 ) . EQ . 1 .OR .KIND (NARGS) .EQ . 1 )  GO  TO  90 

RPR  700 

DO  80  1=1, NARGS 

RPR  710 

NSIGDS ( I )=8 

RPR  720 

NF (I )=1 

RPR  730 

NWM(I)=0 

RPR  740 

NWMAX(I)=13 

RPR  750 

80 

IRGS (I )=IARGS (I ) 

RPR  760 

CALL  CHKCOL  (J) 

RPR  770 

IF  (J.NE.O)  GO  TO  50 

RPR  780 

NA=NARGS 

RPR  790 

GO  TO  160 

RPR  800 

C 

LAST  ARGUMENT  IS  NOT  AN  INTEGER,  NSIGDS  IS  GIVEN 

RPR  810 

90 

IF  (KIND(l) .EQ.l)  GO  TO  130 

RPR  820 

LL=0 

RPR  830 

DO  100  1=1, NARGS 

RPR  840 

IF  (KIND (I ) .EQ.O)  GO  TO  100 

RPR  850 

LL=LL+1 

RPR  860 

ARGS (LL)=ARGS ( I ) 

RPR  870 

100 

CONTINUE 

RPR  880 

NL=0 

RPR  890 

DO  120  1=1, NARGS 

RPR  900 

IF  (KIND ( I ) .EQ.O)  GO  TO  110 

RPR  910 

NL=NL+1 

RPR  920 

GO  TO  120 

RPR  930 

110 

I2=I-NL 

RPR  940 

IARGS(I2)=IARGS(I) 

RPR  950 

N5IGDS(I2)=ARGS(NL+1) 

RPR  960 

NWMAX(I2)=13 

RPR  970 

NF(I2)=1 

RPR  980 

NWM(I2)=0 

RPR  990 

IRGS (I2)=IARGS (12) 

RPR1000 

120 

KIND ( 12 )=0 

RPR1010 

NA=NARGS-NL 

RPR1020 

NARGS=NA 

RPR1030 

CALL  CHKCOL  (J) 

RPR1040 

IF  (J.NE.O)  GO  TO  50 

RPR1050 

GO  TO  160 

RPR1060 

C 

FIRST  ARGUMENT  IS  NOT  AN  INTEGER,  PARAMETERS  ARE 

GIVEN. 

RPR1070 

130 

IF  (ARGS(l) .LE.O.)  GO  TO  50 

RPR1080 

IRVSP=ARGS(1) 

RPR1085 

NPAR=(NARGS-1) /IRVSP 

RPR1090 

IF  (NPAR . NE . 2 .AND .NPAR .NE .3 . AND . NPAR .NE  .4)  GO  TO 

30 

RPR1100 

A ( 1 ) =ABS ( FLOAT (NPAR ) * ARGS ( 1 ) +1 . -FLOAT (NARGS ) ) 

RPR1110 

IF  (A(l)  .GT.O.O)  GO  TO  30 

RPR1120 

NA=ARGS (1 ) 

RPR1130 

DO  150  1=1, NA 

RPR1140 

ISUB=2+NPAR*(I-1) 

RPR1150 

IRGS (I )=IARGS ( ISUB) 

RPR1160 

IARGS (I )=IARGS (ISUB) 

RPR1170 

275 


pii 1      ihnrf C      /TCMD  TADPC/T\\ 

CALL  AUKtbb    ( lbUd , lARbb  ( 1 ) ) 

RPR1180 

ir      /TADPC/T\     1  C     A  \     PP.    TP     C  A 

lr    ( 1 AKbb ( 1 )  . Lt .  0 )   bU    IU  50 

n  n  n  n  i  a  a 

RPR1190 

1Mb  1  bUb  (1  ) =1 AKbb  ( 1 bUB  +  1  ) 

D  D  D  1  1  A  A 

KrK 1 ZOO 

Kl  UJM  A  V  /  T  \      T  A  DP  C  /  T  C 1 1 D  •  O  \  #  /  M  D  A  D  /  1  \  •  O  O  *  /  1     MDAD  /  1  \ 

NWMAX  (l)  =  lAKbb(lbUb+<:)    (NrAK/3)+Z2    ( 1-IMr  AK  /  3  ) 

d  n  D  1  A  1  A 

KHK1210 

Nr ( 1 )=1 

R  D  D  1  AAA 

KHK1220 

hi  UfM  /  T  \  a 

N WM ( 1 ) =0 

nnni  a  o  a 

RPR1230 

IP      /  Al  UlAJ  A  V  /  T  \     rT     A  \     PP.     TP     1  c  A 

It-    (NWMAX  ( I  )  .  b  1  .  0  )   bU    IU  150 

n nn i  a  a  a 

RPR1240 

T  IT      I  Al  MfklA  V/T\      IT     A  \     PfV    TP     l  »  A 

lr    (NWMAX ( 1 ). L 1 . 0 )   bU   IU  140 

n  n  n  i  a  r  a 

RPR1250 

p 

CI  P  A  T  T  Al  P 

r  LUA  1  1 1Mb 

D  D  D  1  A  /  A 

KrKlZoO 

IMW1 U  1  n  (  1  )  =IMb  1 bUb ( 1 ) +5 

DDDl 07rt 

Kr  K1Z / 0 

Al  fl  C  P  C  /  T  \     MCTPHC  /  T  \  .  O 

NUtbb ( 1 )=Nb IbUb ( 1 )+Z 

d  n  D  1  AAA 

RHR1280 

Al  C  /  T  \  1 

Nr ( 1 )=-l 

nnoi AAA 

KHK1290 

Al  Uiftd  /  T  \  1 

NWM( 1 )=-l 

nnoi O  A  A 

KHK1300 

TP     1  C  A 

bU    IU  150 

o  n  D  1  1  1  A 

RHK1310 

p 

r  1  AtU 

DDDl  1 O  A 

KrKl  it.  0 

IM  W 1  U  1  n  (  1  )  =— IM  WMA  X  (  1  ) 

DDDl lin 

KKK1330 

NUtLb ( 1 ) =Nb 1  bUb (1 ) 

DDDl  1  A  A 

KPK1340 

Nb 1 bUb ( 1 ) =8 

o  n  D 1  OCA 

AJUfM  /  T  \  1 
[M  WNI  (  i  )  =—1 

KrK  JOOO 

I  5U 

MDI  AMV  f  I  \     T  A  DP  C  /  T  CI  ID  ■  1  \  *  1 UD  A  D  /  A  \  •  a  *  A  1     M  D  A  D  /  >1  \ 
IMDLAIMi\  (  1  )=lAKbb(lbUD+3)     (NrAK/4)+3    ( 1— IMr  AK  /  4  ) 

DDDl  1 7  A 

KrK  1.5  /  0 

T  C  /  Al  D  A  D     m     A     A  Al  A     Al  D  1   A  Al  1/  /  1  \     IT     "l  \     hi  D  1   A  Al  1/  /  1  \  1 

1 r  (NPAK  .  LQ . 4 . AND . NBLANK ( 1 )  .  LT  .  1 )   NBLANK ( 1 ) =1 

n  r\  n  i  o  t  c 

RPR1375 

p 

1   T  Al  C  C     l  /  A     TP     1  jl  n     TAITTTAI   T  7  C     A  Al  A     PAI  1  CVCADP 

LINtb   160    IU  240   1N1 1 lALlZt  AND  LALL  rXrAKb 

KHK1380 

lot) 

TC      /  Al  C  D  D  P  D     Al  C     A  \     PP     TP     yl  A  A 

lr    ( NtKKUK  .  Nh . 0 )   bU    IU  400 

DDDl  1  Ct  A 

KHK1390 

TC      /II     AIC     £  \     PP    TP     O  1  A 

lr    (Ll.Nt.6)   bU    IU  210 

onoi A  A  A 

KrK1400 

T  1  1 
1  1  =  1 

KrK 140D 

TO  A 

1  2=0 

KPK1410 

lOD 

LL=1 

DDDl  A  1  C 

KHK1415 

TO     Al  T  Al  A  /  A     Al  A  \  TO 

I2=MIN0 (8 , NA ) +1 2 

in  n  n  i  a  a  a 

RPK1420 

Al  A      AD  A  a 

nnn i  a  a  c 

RPR1425 

fl  P    OAA     T     T 1  TO 

UU  200   1=1 1,12 

DDDl  A  1(\ 

KrK1430 

V     T  A  DP  C  / T  \  . M  D  1 

K=l  AKbb  ( 1  )  +NKJ 

DDDl  A  A  A 

KKK1440 

IF  (NWMAX(I) .LE.0)  GO  TO  170 

RPR1450 

CALL  RF0RMT  (RC(K) , 1 , NSIGDS ( I ) ,NWIDTH ( I ) ,NDECS(I) , NWMAX (I) ,A(1) ,A(RPR1460 

11)  ,0,0) 

RPR1470 

1  in 

1  /  u 

IF  (NPAR.EQ.l)  NBLANK(I)=15-NWIDTH(I) 

RPR1480 

CALL  RF0RMT  (A,NF(I) , NS IGDS ( I ) , NWI 0TH ( I ) , NDECS (I ) ,NWM(I ) ,RC (K) ,A(LRPR1490 

1L) , NBLANK (I) ,0) 

RPR1500 

LL=LL+NWIDTH ( I ) +NBLANK ( I ) 

RPR1510 

IF  (NWIDTH(I) .LT.NWMAX(I) .OR.NWMAX(I) .LE.0)  GO  TO  200 

RPR1520 

IF  (NBLANK ( I ) .EQ.0)  GO  TO  200 

RPR1530 

I5=LL-NDECS(I)+NSIGDS(I)-1 

RPR1540 

IF   (A(I5)-AL(39) )  180,190,180 

RPR1550 

180 

IF   (A(I5)-AL(40))  200,190,200 

RPR1560 

T  A  A 

K=LL-NWIDTH ( I )-l 

RPR1570 

A(K)=AL(41) 

RPR1580 

1  A  A 

200 

CONTINUE 

RPR1590 

NL=MIN0(LL-1,120) 

RPR1600 

WRITE  (IPRINT,410)   (A ( I ) , 1=2 , NL ) 

RPR1610 

IF(NA.LE.O)  GO  TO  400 

RPR1615 

11=12+1 

RPR1620 

GO  TO  165 

RPR1625 

210 

11=1 

RPR1630 

DO  240  1=1, NA 

RPR1640 

K=IARGS(I) 

RPR1650 

C 

DETERMINE  COUNT  OF  COL  I 

RPR1660 

NC0UNT(I)=NRMAX 

RPR1670 

DO  220  J=1,NRMAX 

RPR1680 

K1=K+NRMAX-J 

RPR1690 

IF  (ABS(RC(KD).GT.O.)  GO  TO  230 

RPR1700 

276 


220 

NCOUNT ( I )=NCOUNT ( I )-l 

RPR1710 

230 

IF  (NCOUNT(I) .GT.NRMAX-3)  NCOUNT ( I )=NRMAX 

RPR1720 

IF  (NCOUNT(I)  .EQ.O)  NWIDTH ( I )=NWMAX (I ) 

RPR1730 

IF   (NCOUNT(I) .EQ.O)  GO  TO  240 

RPR1740 

IF  (NWMAX(I) .LE.O)  GO  TO  240 

RPR1750 

CALL  RFORMT  (RC(K) , NCOUNT (I) , NSIGDS (I ) , NWIDTH (I) ,NDECS(I) , NWMAX ( I ) RPR1760 

1 ,A(1) ,A(1) ,0 ,0) 
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IF  (NPAR.EQ.l)  NBLANK(I)=15-NWIDTH(I) 

RPR1780 

c 

LINES  250  TO  390  CALL  FXFORM  AND  PRINT  IN  READABLE  FORMAT 

RPR1790 

250 

IF  (L1.NE.8)  CALL  PAGE  (4) 

RPR1800 

14=0 

RPR1810 

DO  260  1=1 1 , NA 

RPR1820 

I4=I4+NWIDTH(I)+NBLANK(I) 

RPR1830 

IF(I4.LE.120)  GO  TO  260 
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14=1-11 
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GO  TO  270 
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IF   (I.EQ.NA)   I4=NA-I 1+1 
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12=14+11-1 
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NARGS=I2-I1+1 

RPR1890 

c 

FROM  HERE  TO  290  PUTS  IN  COL  HEADING  IF  FIRST  ARG  NOT  A  COL  NO. 

RPR1900 

IF  (NPAR.EQ.l)  GO  TO  290 

RPR1910 

CALL  RFORMT  (A , 1 , 1 , 119 , 119 , 0 , 1 . 0 , A ( 1 ) , 0 , 0 ) 

RPR1920 

LL=1 

RPR1930 

DO  280  1=11,12 
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LL=LL+NWIDTH ( I ) +NBLANK ( I ) 
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IF  (NWIDTH(I) . LT . 6 .OR . NCOUNT ( I ) .EQ.O)  GO  TO  280 

RPR1960 

A(200)=IRGS(I) 
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I5=FL0G10(A(200) )+1.0 
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CALL  RFORMT  (A , 1 , 1 5 , 6 , 0 , 0 , A (200 ) , A (LL-6 ) , 0 , 0 ) 
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A(LL-1)=AL(45) 
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IF  (NWIDTH(I) .LT.12)  GO  TO  280 
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A(LL-12)=AL(13) 
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A(LL-11)=AL(25) 
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A(LL-10)=AL(22) 
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A(LL-9)=AL(31) 
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A(LL-8)=AL(23) 
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A(LL-7)=AL(24) 
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280 

CONTINUE 
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WRITE  (IPRINT.410)   (A ( I ) , 1=2 , LL ) 
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GO  TO  320 
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290 

IF  (L1.EQ.8)     GO  TO  325 

RPR2110 

CALL  HEADS  ( IRGS (11) ,14,0,1) 

RPR2120 

DO  310  1=11,12 

RPR2130 

IF  (NCOUNT(I)  .GT.O)  GO  TO  310 

RPR2140 

15=12* (I-I1)+1 

RPR2150 

DO  300  16=1,12 

RPR2160 

LHEAD(I5)=L(45) 

RPR2170 

300 

15=15+1 
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310 

CONTINUE 

RPR2190 

15=12*14 
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WRITE  (IPRINT,420)   (LHEAD ( 16 ) , 16=1 , 15 ) 

RPR2210 

320 

WRITE  (IPRINT,410) 

RPR2220 

325 

DO  390  J=1,NRMAX 

RPR2230 

LL=1 

RPR2240 

DO  350  1=11,12 

RPR2250 

K=IARGS(I)+J-1 

RPR2260 

C 

PRINT  BLANKS  IF  NCOUNT(I)  LT  NRMAX 

RPR2270 

IF  (J.GT.NCOUNT(I))  NDECS ( I )=NWIDTH ( I ) 

RPR2280 

CALL  RFORMT  (A , NF ( I ) , NSIGDS ( I ) , NWIDTH (I) , NDECS (I) , NWM( I ) , RC (K) ,A(LRPR2290 
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c 
c 
c 
c 
c 
c 
c 
c 
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c 
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110 
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140 
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190 
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210 


SUBROUTINE  SELECT  SEL 
VERSION    5.00  SELECT  5/15/70  SEL 

COMMON  /BLOCRC/  NRC , RC ( 12600 )  SEL 
COMMON  /BLOCKO/  IARGS(IOO) , KIND (100) ,ARGTAB (100) , NRMAX , NROW, NCOL , NSEL 


1ARGS,VWXYZ(8) ,NERROR 
DIMENSION  ARGS(IOO) 
EQUIVALENCE   ( ARGS ( 1 ), RC ( 12501 ) ) 
COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG 
COMMON  /SCRAT/  NS , NS2 , A  ( 13500 ) 


ITYPE=1 


ITYPE=1 


ITYPE=1 


ITYPE=2 


ITYPE=3 

ITPE=5 
WRITTEN 


COL 


++ 


++ 


SELECT  IN  COL  ++  VALUES  APPROX 

STORE  IN  COL  ++ 

SELECT  IN  COL  ++  VALUES  APPROX  COL 

STORE  IN  COL  ++  TO  COL  ++ 

SELECT  IN  COL  ++  VALUES  APPROX  COL  ++  TO  WITHIN 

STORE  ++  TO  ++,  STORE  NUMBER  FALLING  WITHIN  TOL 


TO  WITHIN  ** 


TO  WITHIN 


IN 


SEL 
SEL 
SEL 
SEL 
SEL 
SEL 
SEL 
SEL 
SEL 
SEL 
SEL 
COSEL 


SEARCH 
FROM 


IN 

++ 


COL 
INTO 


++ 
++ 


FOR  NUMBERS 
INTO 


++ 


++, 


SEL 

IN  ++,  TRANSFER  CORRESP  VSEL 
ETC  SEL 

SEL 

CENSOR  COL  ++  FOR  $$,  REPLACING  BY  $$,  STORE  IN  COL  ++SEL 

SEL  220 
(C)SEL  225 


10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
180 
190 
200 
210 


MATCH  COLUMN  (C)  WITH  (E) ,  EXTRACT  (E) ,  PUT  IN  COLUMN 
BY  DAVID  HOGBEN  SEL,  NBS .       2/28/70.     (CENSOR  REVISED) 


GO  TO  (10,100,130,40,130),  L2 

IF   (KIND(3))  50,20,50 

K=3 

CALL  ERROR  (K) 
RETURN 

IARGS(3)=IARGS(2) 
KIND(3)=0 

IF   (NARGS-4 )  60,70,80 
K=10 

GO  TO  30 
K=ll 

GO  TO  30 

IARGS(5)=IARGS(4) 

NARGS=NARGS+1 

KIND(5)=KIND(4) 

IF  (NARGS-6 )  90,90,60 

IF  (IARGS(4)-IARGS(5) )  230,230,20 

IF  (NARGS-4)  60,110,110 

IF   (2*(NARGS/2)-NARGS)  60,120,60 

CALL  CHKCOL  (J) 

IF  (J)  20,200,20 

IF  (NARGS-4)  60,140,60 

CALL  ADRESS  (1,11) 

IF   (II)  20,65,150 

CALL  ADRESS  (2,12) 

IF  (12)  160,65,170 

12  =  -12 

CALL  ADRESS  (3,13) 
IF  (13)  180,65,190 

13  =  -13 

CALL  ADRESS  (4,14) 
IF  (14)  20,65,200 
IF  (NRMAX)  210,210,220 
K  =  9 


SEL  230 
SEL  235 
SEL  240 
SEL  250 
SEL  260 
SEL  270 
SEL  280 
SEL  290 
SEL  300 
SEL  310 
SEL  320 
SEL  330 
SEL  335 
SEL  337 
SEL  340 
SEL  350 
SEL  360 
SEL  370 
SEL  380 
SEL  390 
SEL  400 
SEL  410 
SEL  420 
SEL  430 
SEL  440 
SEL  450 
SEL  460 
SEL  470 
SEL  480 
SEL  490 
SEL  500 
SEL  510 
SEL  520 
SEL  530 
SEL  540 
SEL  550 
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btL    O  /  U 

inn 
3UU 

PflMT  T  Ml  IC 
bUlM  1  1  IMUL 

cci  aan 

JtL  OOU 

TC     1 M    1  *  M  D  MA  Y    1  \     51  n    Jin  lcp 
lr    (M— 3   IMKMAA-1  )  31U,33U,33U 

cci  non 

JtL  07U 

310 

TC      IMADPC     C\     A  A  A     A  A  A     1  O  A 

lr    (IMAKbb-3)  440,44U,3aU 

cci  onn 

JtL  7UU 

OOA 

320 

dp / n \    a  a 
Kb ( J  1 )=0 . 0 

cci    o i  n 
btL  V1U 

pn    TPi    A  A  A 
bU    1 U  44U 

cci  Qon 

J  C  L    7  C  U 

1 1  o 
330 

DP/Tll  A/M\ 
Kb  (  1  1  )  =A  ( IM  ) 

cci  Q^n 

JtL    7  J U 

TC      /MADPC     C\     A  A  A     A  A  A     1  A  (\ 

lr    (IMAKbb-3)  44U,44U,34U 

CCI  QAC\ 
JtL  74U 

O  >9  A 

340 

Dp  /  1  1  1      1  A 

RC ( J  1 )  =  1 . 0 

cci  ocn 

jtL  73U 

r*  A     T  f\      A  A  A 

bU    IU  440 

cci    q  a  n 

JtL  70U 

OCA 

350 

111      ?  ^IIDIIAV  O 

Ml=3  NKMAX+2 

CCI  07(1 
JtL   7 / U 

O  Z  A 

360 

I/O  A 

K2=0 

cci  oon 

JtL  70U 

nn    ooa    i    mi  M 
UU   380  J=M1 , M 

cci  oon 

JtL     7  7  U 

TC      /A/l\     A/I     1\\      5  7A     OOA  OOA 

lr    (A ( J ) -A ( J-l ) )  3/0,380,380 

cci  i  nnn 

JtLlUUU 

OTA 

370 

AT     A  /   1  \ 
A  1  =A  (  J  ) 

cci  i  m  n 

A   /    1  \       A   /    1      1  \ 

A (J )=A (J-l) 

cci i non 

J  t  L  1  U  A  u 

A   /    1      *l   \  AT 

A (J-l ) =A I 

cci  l  n i n 

JtLIU JU 

M     1  . MDMA  V 

N=J  +NKMAA 

CCI  1  0A() 

AT     A /Ul 

A  1 =A (N ) 

cci  i  ncn 

JLL1U JU 

A (N )=A (N-l ) 

cci  i  nAn 

jtLlUOU 

A    /  Al      1    \  AT* 

A (N-l )=AT 

cci  l  n7n 
JtL I u / u 

K2=K2+1 

cci  i  nnn 

JtLlUOU 

1  O  A 

380 

PnAITTAIIIC 

bUN 1 1 NUt 

c pi  i  nan 

OLL1U7U 

T  r"       /  1/  O  \       OAA       OAA  OZA 

IF   (K2)  390,390,360 

cci  1 1  nn 

JtL 1 1UU 

3VU 

M    A IMDMAY  •  1 
IM  =  4    IMKMA  A  +  l 

ccilllO 

400 

RC(I1)=A(N) 

SEL1120 
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1 1=1 1+NR0W 

SEL1130 

N=N+1 

SEL1140 

IF   (N-M-NRMAX)  410,410,420 

SEL1150 

410 

IF   (I1-I-IARGS(5)+1)  400,400,420 

SEL1160 

420 

IF   (NARGS-5 )  440,440,430 

SEL1170 

430 

RC(J1)=M-3*NRMAX 

SEL1180 

440 

CONTINUE 

SEL1190 

GO  TO  40 

SEL1200 

C 

SEARCH 

SEL1210 

450 

I1=NARGS-1 

SEL1220 

DO  470  I=1,NRMAX 

SEL1230 

K=IARGS(1)+I-1 

SEL1240 

L=IARGS(2)+I-1 

SEL1250 

M=NRMAX+I 

SEL1260 

A(I)=RC(L) 

SEL1270 

A(M)=RC(K) 

SEL1280 

J  1=2 

SEL1290 

DO  460  N=3,I1,2 

SEL1300 

L=J1*NRMAX+I 

SEL1310 

M=IARGS(N)+I-1 

SEL1320 

A(L)=RC(M) 

SEL1330 

460 

J1=J1+1 

SEL1340 

DO  470  N=4,NARGS,2 

SEL1350 

M=IARGS(N)+I-1 

SEL1360 

470 

RC(M)=0.0 

SEL1370 

K=NRMAX+1 

SEL1380 

L=2*NRMAX 

SEL1390 

DO  510  I=1,NRMAX 

SEL1400 

AT=ABS(A(I)/1.E8) 

SEL1410 

DO  500  J=K,L 

SEL1420 

IF  (ABS(A(I)-A(J) )-AT)  480,480,500 

SEL1430 

480 

Jl=l 

SEL1440 

DO  490  N=4,NARGS,2 

SEL1450 

M=IARGS(N)+I-1 

SEL1460 

I1=J1*NRMAX+J 

SEL1470 

RC(M)=A(I1) 

SEL1480 

490 

J1=J1+1 

SEL1490 

GO  TO  510 

SEL1500 

500 

CONTINUE 

SEL1510 

510 

CONTINUE 

SEL1520 

GO  TO  40 

SEL1530 

C 

CENSOR  OR  MATCH 

SEL1540 

520 

DO  580  1=1 , NRMAX 

SEL1550 

IF  (RC(Il)-RC (12) )  540,530,560 

SEL1560 

530 

RC(I4)  =  RC(I3) 

SEL1570 

GO  TO  570 

SEL1580 

540 

IF  (L2-4)  530,40,570 

SEL1590 

560 

IF  (L2.EQ.5)     GO  TO  570 

SEL1600 

RC(I4)  =  RC  (11) 

SEL1610 

570 

11  =  11+1 

SEL1620 

IF  (KIND(2) .EQ.O)  12=12+1 

SEL1630 

IF  (KIND(3) .EQ.O)  13=13+1 

SEL1640 

580 

14  =  14+1 

SEL1650 

GO  TO  40 

SEL1660 

END 

SEL1670 
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SUBROUTINE  SET  SET  10 

C         VERSION    5.00         SET              5/15/70  SET  20 

COMMON  /BLOCKA/  MODE , M, KARD (83 ) ,KARG , ARG , ARG2 ,NEWCD (80 ) ,KRDEND        SET  30 

COMMON  /BLOCRC/  NRC  ,RC  (12600)  SET  40 

COMMON  /BLOCKD/  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NSET  50 

1ARGS ,VWXYZ (8) ,NERROR  SET  60 

DIMENSION  ARGS(IOO)  SET  70 

EQUIVALENCE  (ARGS ( 1 ), RC  ( 12501 ) )  SET  80 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , ISRFLG  SET  90 

COMMON  /QRS/  NDROW, IFLAG , J ,NNARG  SET  100 

C           THE    FOLLOWING    CARDS  ARE    NEDDED    ONLY  FOR  TAPE  OPERATIONS         SET  110 

COMMON  /TAPE/  NAME4 (2 ) , NTPCT , IPUNCP , INUNIP , L1TP  SET  120 

COMMON  /BLOCKC/  KIO.INUNIT, ISCRAT ,KBDOUT ,KRDKNT , LL I  ST  SET  130 

ISRFLG=1  SET  150 

IF  (NARGS . EQ . 1 .OR .NARGS .EQ . 2 )  GO  TO  10  SET  160 

CALL  ERROR  (10)  SET  170 

GO  TO  70  SET  180 

10        M0DE=2  SET  190 

CALL  ADRESS  (NARGS, J)  SET  200 

IF  (J)  20,30,40  SET  210 

20        CALL  ERROR  (3)  SET  220 

GO  TO  70  SET  230 

30        CALL  ERROR  (11)  SET  240 

GO  TO  70  SET  250 

40        NDR0W=J+NR0W-1  SET  260 

IF  (NARGS. EQ.l)  GO  TO  60  SET  270 

IF  (KIND(l)  .NE.O)  GO  TO  20  SET  280 

IF  (IARGS(l) .LE. NROW. AND. IARGS(l) .GT.O)  GO  TO  50  SET  290 

CALL  ERROR  (16)  SET  300 

GO  TO  70  SET  310 

50        J=J+IARGS(1)-1  SET  320 

60        IFLAG=0  SET  330 

M0DE=2  SET  340 

GO  TO  80  SET  350 

70        IFLAG=1  SET  360 

C           THE    FOLLOWING    CARDS  ARE    NEDDED    ONLY  FOR  TAPE  OPERATIONS         SET  370 

IF  (L1TP .NE .48 .AND .L1TP .NE .49)  RETURN  SET  380 

M0DE=1  SET  390 

INUNIT=INUNIP  SET  400 

80        RETURN  SET  420 

END  SET  430 
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SUBROUTINE  SETQ  STQ  10 

C          VERSION     5.00          SETQ             5/15/70  STQ  20 

COMMON  /BLOCRC/  NRC  , RC  ( 12600 )  STQ  30 

COMMON  /BLOCKD /  IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NSTQ  40 

IARGS ,VWXYZ (8) ,NERROR  STQ  50 

DIMENSION  ARGS(IOO)  STQ  60 

EQUIVALENCE   ( ARGS (1 ), RC ( 12501 ) )  STQ  70 

COMMON  /QRS/  NDROW, IFLAG , J ,NNARG  STQ  80 

COMMON  /BLOCKA/  MODE , M, KARD (83 ) , KARG , ARG , ARG2 , NEWCD (80 ) ,KRDEND        STQ  90 

COMMON  /BLOCKC/  KIO , INUNIT , I SCRAT , KBDOUT , KRDKNT , LLIST  STQ  100 

COMMON  /TAPE/  NAME4 (2 ) ,NTPCT , IPUNCP , I NUN  IP , L1TP  STQ  110 

C         CHECK  IF  END  OF  ROW  HAS  BEEN  EXCEEDED  PREVIOUSLY  IN  THIS  SET.  STQ  120 

IF  (IFLAG. NE.O. OR. NARGS.EQ.O)  GO  TO  80  STQ  130 

C         J  IS  WHERE  NEXT  DATA  ITEM  IS  TO  GO  IN  COLUMN  STQ  140 

C         JJ  IS  WHERE  LAST  DATA  ITEM  OF  THIS  SET  IS  TO  GO                                 STQ  150 

C         NDROW  IS  ADDRESS  OF  LAST  ELEMENT  OF  ROW.  STQ  160 

JJ=J+NARGS-1  STQ  170 

IF  (JJ .LE. NDROW)  GO  TO  10  STQ  180 

CALL  ERROR  (201)  STQ  190 

IFLAG=1  STQ  200 

IF  (J. GT. NDROW)  GO  TO  80  STQ  210 

JJ=NDROW  STQ  220 

C           THE  FOLLOWING  CARDS  ARE  NEEDED  ONLY  FOR  TAPE  OPERATIONS                  STQ  230 

10        IF   (L1TP.NE.48)  GO  TO  50  STQ  240 

K=l  STQ  250 

DO  30  I=J,JJ  STQ  260 

IF  (KIND(K) .EQ.O)  GO  TO  20  STQ  270 

IF  (ARGS(K) .NE.O. )  GO  TO  50  STQ  280 

GO  TO  30  STQ  290 

20        IF  (IARGS(K) .NE.O)  GO  TO  50  STQ  300 

30        CONTINUE  STQ  310 

40        INUNIT=INUNIP  STQ  320 

M0DE=1  STQ  330 

RETURN  STQ  340 

C           THIS  STATEMENT  WAS      10    K=l  STQ  350 

50        K=l  STQ  360 

DO  70  I=J , JJ  STQ  380 

IF  (KIND(K) .EQ.O)  GO  TO  60  STQ  390 

RC(I)=ARGS(K)  STQ  400 

GO  TO  70  STQ  410 

60        RC(I)=IARGS(K)  STQ  420 

70        K=K+1  STQ  430 

J=JJ+1  STQ  440 

NRMAX=MAXO(NRMAX,JJ-NDROW+NROW)  STQ  450 

C           THE  FOLLOWING  CARDS  ARE  NEEDED  ONLY  FOR  CSET  TAPE                            STQ  460 

IF  (L1TP.NE.49)  RETURN  STQ  470 

NTPCT=NTPCT-1  STQ  480 

IF  (NTPCT.EQ.O)  GO  TO  40  STQ  490 

q          s**************************^  * *STQ  500 

80        RETURN  STQ  510 

END  STQ  520 
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CIIRRnilTTMF  CFTIID 

CTD 
o  1  r 

10 

L 

VCKjIUIM      D.UU             jt  1  Ur  3/X3//U 

CTD 
0  1  r 

0  ft 

rnMMDN  /ri  nrKA  /  winnF  m  i^ADn  ja^ i  karg  art,  art,9  NFwrn c rd  i  KRnFiun 

j  1  r 

3  u 

po-mmon  /RinPkr/  kin  tniiimtt  tcprat  KRnniiT  krdkimt  iit^t 

CTD 

4  U 

COMMON  /BLOCRC/  NRC  , RC  ( 12600  ) 

STP 

0  u 

COMMON  /BLOCKD /  IARGS(IOO) ,KIND(100) ,ARGTAB(100) , NRMAX ,NR0W,NC0L ,NSTP 

L  ft 

1ARGS  VWXYZffU  NFRRDR 

STP 

7  n 

DIMENSION  ARGSflOO^ 

u  i.  ifiL.ll  J  l  uil     n  i\  \j  J  y  A.  \J  \J  j 

STP 

ou 

EQUIVALENCE   (ARGSd^  RC(1250in 

STP 

•j  i  r 

q  n 
7  u 

COMMON /HEADER /NOCARD ( 80 )   ITLEf&O  h)   LNCNT  IPRINT  NPAGE  IPUNCH 

STP 

i  n  n 

1UU 

COMMON /PKSWT / IHCNT  IHTP 

K'  \J  Ifllf  lw  11  /  r  l\  J  11  1    /  1  1  1     11  1    ,  1  1  1  1  r 

STP 

1 1  u 

COMMON    /SPRAT  /   NS  NS?   A  ( T  3  5(10  ^ 

STP 

1  i.  U 

COMMON  /ICODE/  NIR  ,NID  ,NIRD  ,LIR , LID  , LIRD 

STP 

LjU 

COMMON  /BLOCKX/  INDEX  (6  , 8 ), LEVEL 

STP 

C0MM0N/PC0NST/JPC,P(40) ,N(40) 

STP 

1  en 
1  3  U 

COMMON  /CONSTS/  PI  ,E ,HALFPI ,DEG ,RAD ,XAL0G 

STP 

1  o  U 

THE  FOLLOWING  CARD  IS      NEEDED  ONLY  FOR  TAPE  OPERATIONS 

STP 

1  /  u 

COMMON  /ICODTP/  NITP,LITP 

STP 

1  0  u 

COMMON  /TAPE/  NAME4 (2 ) , NTPCT , IPUNCP , I  NUN  IP , L1TP 

STP 

T  ft  A 

190 

r 

******************************************************** 

P(1)=PI 

STP 

9 1  n 

P (2)=PI 

STP 

99(1 
L  L  U 

P(3)=E 

STP 

9 

P (4)=E 

STP 

9dn 

KRDEND=80 

STP 

9  <;n 

t  J  u 

NERR0R=0 

STP 

9  An 

L  0  U 

LEVEL=0 

STP 

M0DE=1 

STP 

9  sn 

IPRINT=6 

STP 

9on 

IPUNCH=3 

STP 

INUNIT=5 

STP 

J  i  u 

ISCRAT=45 

STP 

NS=13500 

STP 

n 

KI0=0 

STP 

•a  AO 

CALL  AERR  (-1) 

STP 

NRC=12500 

STP 

NS2=NS/2 

STP 

37n 

r 

THESE  VARIABLES  MUST  BE  REDEFINED  IF  A  NEW  COMMAND  IS  ADDED 

STP 

%  Rn 

NIR=246 

STP 

NIRD=29 

STP 

*T  W  U 

NID=8 

STP 

din 

LIR=300 

STP 

LID=9 

STP 

H  ^  U 

LIRD=30 

STP 

dan 

L 

THE  FOLLOWING  CARD  IS      NEEDED  ONLY  FOR  TAPE  OPERATIONS 

STP 

NITP=9 

STP 

tuu 

LITP=10 

STP 

*t  /  u 

INUNIP=INUNIT 

STP 

ARO 

IPUNCP=IPUNCH 

STP 

A  ft  ft 

490 

L 

******************************************************************5jp 

p 
1/ 

STP 

510 

L 

**  THESE  SWITCHES  MUST  BE  SET  BEFORE  COMPILING.  NEEDED  INFORMATIONSTP 

D  £.  U 

C 

FOR  PACKING  HEADS  AND  FORMATS. 

STP 

c  *a  f| 

L 

STP 

JtU 

U 

IHTP-  NO.  OF  HEADINGS  PERMITTED. 

STP 

j  j  y 

THIS  IS  SET  =  50  ,  HOWEVER  IN  ORDER  TO  SAVE  SPACE  ONE  MAY  DESIRE 

STP 

TO    PERMIT  FEWER  HEADINGS.  IF  SO    DIMENSION  STATEMENT  IN  PREPAK 

STP 

570 

o 

FOR  VARIABLE  IHEAD  MUST  BE  CHANGED.  SECOND  VALUE  OF  IHEAD  INDI- 

STP 

580 

J  o  w 

C 

CATES  TOTAL  NO.  OF  HEADINGS 

STP 

590 
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C  STP  600 

IHTP=50  STP  610 

C  STP  620 

RETURN  STP  630 

END  STP  640 


SUBROUTINE  SKSYMV  (A,NROW,N,K)  SKS  10 

C         VERSION    5.00         SKSYMV         5/15/70  SKS  20 

C         FOR  OMNITAB  MATRIX      S  PEAVY    1/  3/68  SKS  30 

C  SKS  40 

C           A  MATRIX  TO    BE  TESTED  FOR  SKEW  SYMMETRY  SKS  50 

C         NROW  DIMENSION  OF  A  SKS  60 

C         N        PRESENT  SIZE  OF  MATRIX  SKS  70 

C         K         STATUS  SKS  80 

C             K=2  NO  SYMMETRY  SKS  90 

C            K=3  EXACT  SKEW  SYMMETRY  SKS  100 

C            K=4  RELATIVE  (l.E-7)  SKEW  SYMMETRY  SKS  110 

C  SKS  120 

DIMENSION  A(NROW,NROW)  SKS  130 

K=3  SKS  140 

NN=N-1  SKS  150 

DO  40  J=1,NN  SKS  160 

IF  (A(J , J) .EQ.O.O)  GO  TO  10  SKS  170 

K=2  SKS  180 

RETURN  SKS  190 

10        I=J+1  SKS  200 

DO  40  L=I,N  SKS  210 

IF  (A(L.J).NE.O.)  GO  TO  20  SKS  220 

T=ABS(A(J ,L) )  SKS  230 

GO  TO  30  SKS  240 

20        T=ABS(1.0+A(L,J)/A(J ,L) )  SKS  250 

30        IF  (T. EQ.O.O)  GO  TO  40  SKS  260 

K=4  SKS  270 

IF  (T.LE. l.E-7)  GO  TO  40  SKS  280 

K=2  SKS  290 

RETURN  SKS  300 

40        CONTINUE  SKS  310 

IF  (A(N,N) .NE.O.O)  K=2  SKS  320 

RETURN  SKS  330 

END  SKS  340 
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SUBROUTINE  SORDER  SOD 
VERSION  5.00  SORDER  5/15/70  SOD 
COMMON  /BLOCRC/  NRC  ,RC  (12600)  SOD 
COMMON  /BLOCKD /  IARGS(IOO) , KIND (100) ,ARGTAB (100 ) , NRMAX , NROW,NCOL ,  NSOD 


C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 

10 
20 
30 
40 

50 

60 
70 
80 
90 
100 

110 
120 

130 


140 
150 


160 
170 

180 


1ARGS,VWXYZ(8) ,NERROR 
DIMENSION  ARGS(IOO) 
EQUIVALENCE  (ARGS ( 1 ), RC  ( 12501 ) ) 
COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG 
COMMON  /SCRAT/  NS ,NS2 , A  (13500 ) 

SUBROUTINE  BY  CARLA  MESSINA  221.04 
L2=8  FOR  SORT,  L2=9  FOR  ORDER,  L2=14  FOR 


JUNE  1967 
HEIRARCHY 


SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 


SOD 

TYPE  1  IS  HEIRARCHY  OF  COL    ++,  STORE  IN  COL  ++  SOD 

HEIRARCHY  GIVES  THE  ROW  LOCATION  OF  THE  SMALLEST  NO.  OF  THE  SOD 
THE  FIRST  COLUMN  IN  THE  FIRST  ROW  OF  THE  SECOND  COLUMN  SOD 
THE  ROW  NO.  OF  THE  SECOND  LOWEST  NO.  OF  THE  FIRST  COLUMN  IS  STOREDSOD 

IN  THE  SECOND  ROW  OF  THE  SECOND  COLUMN  THE  ROW  NO.  OF  THE  SOD 

LARGEST  NO.  OF  THE  FIRST  COL  IS  STORED  IN  THE  NRMAX  ROW  OF  THE  2NDS0D 


COLUMN.     THE  FIRST  COLUMN  IS  UNCHANGED  BY  THIS  COMMAND. 
TYPE  2  IS      ORDER  COLUMNS  ++,++,++,  ETC 

ORDER  PLACES  EACH  ONE  OF  THE  GIVEN  COLUMNS  IN  NUMERICALLY 
INCREASING  ORDER. 

TYPE  3  IS      SORT  COL  ++  CARRY  ALONG  COLUMNS  ++,++,  ETC 

SORT  PLACES  THE  FIRST  COLUMN  IN  NUMERICALLY  INCREASING  ORDER 
WHILE  PRESERVING  THE  ROW  RELATIONSHIPS  AMONG  THE  GIVEN  COLUMNS 

THESE  INSTRUCTIONS  CAN  BE  DONE  FASTER  IF  A  MACHINE  LANGUAGE 
PROGRAM  IS  SUBSTITUTED  FOR  THIS  ONE. 


10,10,40 


IF  (NARGS) 
K=10 

CALL  ERROR  (K) 
RETURN 

CALL  CHKCOL  (J) 
IF  (J)  50,60,50 
K=3 

GO  TO  20 

IF  (L2-9)  80,80,70 

IF  (NARGS-2)  10,80,10 

IF  (NERROR)  30,90,30 

IF  (NRMAX-1)  100,110,120 

K=9 

GO  TO  20 

IF  (L2-9)  30,30,210 
K3=l 

K=IARGS(1)-1 

DO  140  1=1, NRMAX 

J=K+I 

L=NRMAX+I 

A(I)=RC(J) 

A(L)=I 

K1=NRMAX 

K1=K1-1 

K2=0 

IF  (Kl-1)  160,160,170 
Kl=2 

DO  190  1=1, Kl 

IF  (A(I)-A(I+1))  190,190,180 
CC=A(I) 


SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 
SOD 


10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
180 
190 
200 
210 
220 
230 
240 
250 
260 
270 
280 
290 
300 
310 
320 
330 
340 
350 
360 
370 
380 
390 
400 
410 
420 
430 
440 
450 
460 
470 
480 
490 
500 
510 
520 
530 
540 
550 
560 
570 
580 
590 
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A ( I )=A ( 1+1 ) 

SOD 

600 

A ( I +1 )=CC 

SOD 

610 

L=NRMAX+I 

CAP* 

SOD 

620 

CC=A (L) 

f  Aft 

SOD 

630 

A(L)=A(L+1) 

c  a  r\ 

SOD 

640 

A (L+l )=CC 

SOD 

650 

K2=l 

SOD 

660 

190 

CONTINUE 

c  A  r* 

SOD 

670 

IF   (K2)  150,200,150 

f  A  r\ 

SOD 

680 

200 

IF   (L2-9)  240,240,220 

c  A  n 

SOD 

/  A  A 

690 

210 

A (NRMAX+1 )=1 . 0 

r*  a  r\ 

SOD 

700 

220 

K=IARGS (2)-l 

SOD 

710 

DO  230  I=1,NRMAX 

SOD 

720 

J=K+I 

f  A  r\ 

SOD 

730 

i      limit  v/  t 

L=NRMAX+I 

c  a  r» 

SOD 

740 

230 

RC ( J )=A (L) 

SOD 

750 

GO  TO  30 

SOD 

760 

240 

DO  250  1=1, NRMAX 

SOD 

770 

J=K+I 

c  a  r* 

SOD 

780 

250 

RC ( J )=A ( I ) 

C  A  f\ 

SOD 

~1  A  A 

790 

IF   (NARGS-2)  30,260,260 

f*  A  r\ 

SOD 

800 

260 

IF   (L2-9)  290,270,270 

f  a  r\ 

SOD 

810 

270 

IF  (NARGS-K3)  30,30,280 

f  a  r\ 

SOD 

820 

A  ft  A 

280 

1/1       I/O  T 

K3=K3+1 

SOD 

A  O  A 

830 

i/     taa/^c/i/ix  i 

K=I ARGS (K3 ) -1 

C  A  T\ 

SOD 

840 

GO  TO  130 

SOD 

850 

290 

DO  310  I=2,NARGS 

f*  A  A 

SOD 

860 

K=IARGS (I )-l 

SOD 

870 

DO  300  J=l , NRMAX 

SOD 

880 

L=NRMAX+J 

CAR 

SOD 

ft  A  A 

890 

11       A/I    \      r*  1    A  A  T"  i  W  \ 

J1=A (L)+FL0AT (K) 

f*  A  A 

SOD 

900 

300 

A(J)=RC(J1) 

SOD 

910 

DO  310  J=l, NRMAX 

SOD 

920 

1  1      1/  1 

J 1=K+J 

SOD 

A  *>  A 

930 

310 

n  A    /    1  1    v  A/It 

RC (J1)=A(J ) 

f*  A  A 

SOD 

940 

GO  TO  30 

SOD 

950 

END 

SOD 

960 
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C 1 IDDOI  IT  T  WP    CnBTQM    (  hi  CIIU\ 

bUM 

ID 

WCDCIflM      c    nn             C  n  D  T  C  U 

e lie  j7h 

cnu 
oUNI 

c  U 

L 

* 

CAM 

i\j 

COMMON  /SCRAT/  NS  ,NS2  ,A  (13500) 

A  ft 

L 

snRT  rni  iimn  nF  products  for 

MATRIX   Mill  TTPI  TPATIflN 

IflH  1  T\  1  A     1VIU  Ll  Ir  L  1UM  1  1UI1 

cnu 

a  ft 

b0 

AFTFR  SORTING  START  SUMMING 

RFGIN   IN  MlIiniF  OF  S0.RTFD  mi  IIMN 

L  ft 

60 

L 

* 

cnu 

7  ft 

1  0 

DIMENSION  XII] 

cnu 

O  ft 

00 

DOIIRI  F  PRFPTSTON  X  SAVF  SUM 

SUM 

Q  ft 
7U 

FOIITVALFNfF    fX  A^ 

COM 

i  nn 

1UU 

T  F    (N  NF   U   Pifl  TO  1(1 
i  r    ^  11  .  11  t_  .  i  )    uu    i  u  x\j 

cnu 

1 1  ft 

1X0 

JUIT^A  ^ll  Jl  ) 

CAM 

ion 
i  i.  yj 

R FT URN 

cnM 

l  7  n 

i  n 
1 U 

cnu 

JUKI 

t  c_nc? 

1  O — ll  -J  L 

cnu 

1  DU 

nn  in  T— 2  n 

cnu 

i  An 

cnu 

i  7  n 

9  n 

SAVE-X  (  T  S-l ^ 

cnu 

ion 

cnu 

i  on 

17U 

X  ( I S  ^-SAVE 

cnu 

onn 
iUU 

K-l 

cnu 

£  1U 

3  U 

I S-I S-l 

cnu 

9  9  n 

IF   <K  NE  0}  GO  TO  10 

IT      ^  l\  .  I1L  .  U  /      VJ  V      1  v     X  w 

cnu 

9  ^n 

NP-N  12 

ii  r  — ii  f  c 

COM 
jUWI 

")  An 

IF    (MODfN  2^   EO  0^   GO  TO  40 

cnM 

9  <;n 

NP  A  — KK?    jVID  I 
llrH— 11  Jt  — 11  r  —  J. 

cnu 

jUWI 

9  An 

NPR— NPAx? 

cnu 

9  7  n 

CIV 

NPC-NS2  NP 

ll  r  v— ll  Jt  — ll  r 

cnu 

jUWI 

SIIM=X  fNPP ) 

cnu 

ion 
t7U 

GO  TO  50 

cnM 

inn 

a  n 
4U 

StJM=0  DO 

J  U  III—  \J  .  U\J 

cnu 

1 1  n 

NPA-NS2-NP 

iir  n— iu  t  ~iir 

COM 
jUWI 

9  n 

NPB-NPA-tl 

ll  r  u— llrnti 

cnM 

jUWI 

nn 

3  J  U 

3  u 

nn  An  t— 1  np 

SOM 

CI ! u  C I  |M_lY  (  NPA  ^  j_y  (  NPR  \ 

j  U  Wf=  jUIwi+A  \  Ii  r  M  J  +A  ^  Iir  D  ; 

SHM 

mn 

J  3  U 

NPA=NPA-1 

SOM 

JUKI 

3  OU 

NPB=NPB+1 

COM 

1 7  n 

3  1  V 

Z.  ft 

60 

CONTINUE 

cnM 

jUWI 

J  OU 

RETURN 

cnu 

jUWI 

ion 

END 

S0M 

400 
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CIIPDmiTTWC  CDAPF 

CD  A 
jrA 

i  n 

L 

CPA 
jrn 

^  n 

COMMON  /BLOCRC/  NRC , RC ( 12600 ) 

SPA 

p  u 

COMMON  /BLOCKD /  IARGS(IOO) , KIND (100) ,ARGTAB(100) , NRMAX ,NR0W,NC0L ,NSPA 

a  n 
4  u 

1  ARGC   \/WYV7fft\  NFRRflR 

spa 

c  n 

rtTMPN^TOKi  ARf.CMnn\ 

CPA 

a  n 
o  u 

Fflll  T  V/AI  FNPF    fARG^MI  Pfunnin 

spa 

7  n 

rOMMON /HFADER /NOfARD / 80 ^    ITLEf60  ft)   LNCNT   IPRINT  NPAGE  IPUNCH 

SPA 

Jin 

n  n 

tf   rhiAR£C  i  ^  An  %o  in 

1  r     ^NMrvOJ  —  I)    4U  ,  ,1U 

CPA 

l  nn 
1  u  u 

1U 

T— i  n 

1  —  X  u 

SPA 

O  r  H 

I  1  (1 

I I  u 

0  f\ 

PAN    FRRDR    f  T  \ 

CPA 

1  O  A 
12U 

i  u 

RETURN 

CPA 

i  ■»  n 

1  J  u 

J  L 

SPA 

J  r  n 

SPA 

i  An 
J.4U 

Gf)  TP.  ?f) 

SPA 

1  D  U 

T  _  7 
1  — J 

CPA 

jrn 

1  L  f\ 

loU 

no  to  ?n 

SPA 

i  7  n 
1  /  u 

An 

T  ARGC  f  1  \  1 

1  Hl\U  J  \  X  )  —  J- 

j  r  H 

1  on 
10U 

<^PA 

j  r  H 

ion 

1  7  u 

IF   (NERROR  NE  0^  GO  TO  30 

SPA 

o  n  n 
z  u  u 

nn  «;n  T— l  i 

uu    3  U    1  =  1, J 

CPA 
or  M 

o  i  n 
<i  1  u 

c  n 

WRITE  (IPRINT, 60) 

SPA 

o  o  n 
ZZU 

GO  TO  30 

SPA 

0  7  A 

r 

L> 

SPA 

5  An 

t4U 

6(J 

FORMAT  (IX) 

SPA 

250 

END 

SPA 

260 
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SUBROUTINE  SPINV  (A ,M,KK , I S I G )  SPI  10 

C         VERSION    5.00         SPINV  5/15/70                                                    SPI  20 

C         7058MI    MATRIX  INVERSION  WITH  MINIMUM  ROUNDOFF  ERROR  ACCUMULATION . SPI  30 

DATA  ONE/J.O/, ZERO/0. 0/,ER/l. £-8/  SPI  40 

DIMENSION  A(l)  SPI  50 

ISIG=0  SPI  60 

N=M  SPI  70 

NN=KK  SPI  80 

N2=N+N  SPI  90 

DO  30  J=1,N  SPI  100 

NJC0L=(N+J-1)*NN  SPI  110 

DO  30  1=1, N  SPI  120 

KINJ=NJCOL+I  SPI  130 

IF  (I-J)  10,20,10  SPI  140 

10        A(KINJ)=ZERO  SPI  150 

GO  TO  30  SPI  160 

20        A(KINJ)=ONE  SPI  170 

30        CONTINUE  SPI  180 

C         DETERMINE  MAXIMUM  ABS  OF  VARIABLE  BEING  ELIMINATED.     THIS  BECOMES  SPI  190 

L=0  SPI  200 

40        L=L+1  SPI  210 

LCOL=NN*L-NN  SPI  220 

KLL=LCOL+L  SPI  230 

IF  (L-N)  50,100,200  SPI  240 

C         FIND  THE  LARGEST  ELEMENT  IN  THE  LTH  COLUMN.                                        SPI  250 

50        J1=L  SPI  260 

C=ABS (A(KLL) )  SPI  270 

L1=L+1  SPI  280 

DO  70  I=L1,N  SPI  290 

KIL=LCOL+I  SPI  300 

X=ABS(A(KIL) )  SPI  310 

IF  (C-X)  60,70,70  SPI  320 

C         RECORD  THE  NUMBER  OF  THE  ROW  HAVING  THE  GREATER  ELEMENT.                  SPI  330 

60        J  1=1  SPI  340 

C         C  BECOMES  THE  GREATER.  SPI  350 

C=X  SPI  360 

70        CONTINUE  SPI  370 

C          INTERCHANGE  ROW  Jl  WITH  ROW  L.  Jl  IS  THE  ROW  WITH  THE  LARGEST  ELEMSPI  380 

C         TEST  TO  SEE  IF  INTERCHANGING  IS  NECESSARY.  SPI  390 

IF  (Jl-L)  80,100,80  SPI  400 

80        DO  90  J=L,N2  SPI  410 

JCOL=NN*J-NN  SPI  420 

KJIJ=JC0L+J1  SPI  430 

HOLD=A(KJIJ)  SPI  440 

KLJ=JCOL+L  SPI  450 

A(KJIJ)=A(KLJ)  SPI  460 

A (KLJ )=HOLD  SPI  470 

90        CONTINUE  SPI  480 

C          IF    THE  LARGEST  ABSOLUTE  ELEMENT  IN  A  COLUMN  IS  ZERO  WE  HAVE  A  SINSPI  490 

100      IF  (ABS(A(KLL) )-ER)  110,110,120  SPI  500 

110      I S I 6=4  SPI  510 

GO  TO  200  SPI  520 

C         ZERO  ALL  THE  ELEMENTS  IN  THE  LTH  COLUMN  BUT  THE  PIVOTAL  ELEMENT .     SPI  530 

120      Ll=l  SPI  540 

L2=L-1  SPI  550 

IF  (L2)  130,130,150  SPI  560 

130      IF  (L-N)  140,170,140  SPI  570 

140      L1=L+1  SPI  580 

L2=N  SPI  590 


290 


150 

DO  160  I=L1,L2 

SPI 

600 

KIL=LCOL+I 

SPI 

610 

Z=-A(KIL) /A(KLL) 

SPI 

620 

DO  160  J=L,N2 

SPI 

630 

JCOL=NN*J-NN 

SPI 

640 

KIJ=JCOL+I 

SPI 

650 

KLJ=JCOL+L 

SPI 

660 

160 

A(KIJ)=A(KIJ)+Z*A(KLJ) 

SPI 

670 

IF   (N-L2)  40,40,130 

SPI 

680 

C 

DIVIDE  BY  DIAGONAL  ELEMENTS. 

SPI 

690 

170 

DO  180  1=1 , N 

SPI 

700 

KKK=NN* I-NN+I 

SPI 

710 

ZZ=A(KKK) 

SPI 

720 

DO  180  J=1,N2 

SPI 

730 

KKI=NN*J-NN+I 

SPI 

740 

180 

A(KKI)=A(KKI) 111 

SPI 

750 

C 

RETURN  AFTER  PUTTING  A  INVERSE  INTO  B 

SPI 

760 

DO  190  J=1,N 

SPI 

770 

JCOL=NN*J-NN 

SPI 

780 

NJCOL=NN*N+JCOL 

SPI 

790 

DO  190  1=1, N 

SPI 

800 

KIJ=JCOL+I 

SPI 

810 

KINJ=NJCOL+I 

SPI 

820 

190 

A(KIJ)=A(KINJ) 

SPI 

830 

200 

RETURN 

SPI 

840 

END 

SPI 

850 
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SUBROUTINE  STATIS  STA  10 

C         VERSION    5.00         STATIS         5/15/70  STA  20 

C         S  PEAVY  STA  30 

C         OMNITAB  COMMAN  IS  AS  FOLLOWS  STA  40 

C  I     WITH  WEIGHTS  STA  50 

C  A.  STATIS    COL  +++    WEIGHTS  +++    START  STORING  RESULTS  +++  STA  60 

C  (RESULTS  WILL  BE  STORED  IN  THE  NEXT  4  COL)  STA  70 

C  B.  STATIS    COL  +++  WHTS  +++  RESULTS  +++,+++,+++,+++  STA  80 

C  II  WITHOUT  WHTS  STA  90 

C  A.  SAME  AS  I.  A.     EXCEPT  WHTS  COL  OMITTED  STA  100 

C  B.  SAME  AS  I.  B.     EXCEPT  WHTS  COL  OMITTED  STA  110 

COMMON  /BLOCRC/  NRC , RC ( 12600 )  STA  120 

COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW , NCOL , NSTA  130 
1ARGS , VWXYZ (8 ) ,NERROR  STA  140 

DIMENSION  ARGS(IOO)  STA  150 

EQUIVALENCE  ( ARGS ( 1 ), RC  ( 12501 ) )  STA  160 

COMMON  /SCRAT/  NS , NS2 , A ( 13500 )  STA  170 

COMMON /HEADER /NOCARD (80) ,ITLE(60,6) , LNCNT , I  PR  I  NT ,NPAGE , I  PUNCH  STA  180 
COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG  STA  200 

DIMENSION  SA(3125,3),   ISA (3125 )  STA  210 

DIMENSION  IB ( 10 )  STA  220 

EQUIVALENCE  ( A ( 101 ) , I SA) ,   (A(3226),SA)  STA  230 

DIMENSION  BC0N(4),  BKC0N(4),  AKC0N(4),  AT5(6),  CK1(6),  DK2(6)(  XKlSTA  240 
1(7) ,  YK2(7)  STA  250 

DATA  BCON(l) ,BC0N(2) ,BC0N(3) , BCON (4 ) /3 . 6948 , -1 . 6561 , .406 ,2 .7764/ ,BSTA  260 
1KC0N(1) ,BKC0N(2) ,BKC0N(3) , BKCON (4 ) /7 . 45894 ,-. 89082 , . 61522 , 2 . 56706 /STA  270 
2,AKC0N(1) ,AKC0N(2) ,AKC0N(3) , AKCON (4 )/-. 5 1732 ,-. 61863 ,-. 04122 , .5589STA  280 
37/ ,AT5 (1) ,AT5 (2) ,AT5 (3) ,AT5 (4) ,AT5 (5) ,AT5 (6) /l  .9599640  ,2  .3722712 ,2STA  290 
4.8224986,2.55  58497,1.5895341,  .  7328982  /,  CK1 ( 1 )  ,CK1 (2 ) ,CK1 (3) ,CK1 (4) STA  300 
5 ,CK1 (5) , CK1 (6 )/-. 70285 ,-.02006, -.01687 ,-.01447 ,-.01263 , . 67839 /, DK2STA  310 
6 (1) ,DK2 (2) ,DK2 (3) ,DK2 (4) ,DK2 (5) ,DK2 (6) /-l .49016, .13384, .09764, .074STA  320 
776,  .05931, 1 .68641/ ,XK1  (1) , XK1 (2) ,XK1 (3) ,XK1 (4) ,XK1 (5) ,XK1 (6) ,XK1 (7 STA  330 
8) /-40. 34387 5, 14. 1365, -2. 743342, .84143957, . 001066 , -6 . 3701507E-6 , 1 . 7STA  340 
949484E-8/ ,YK2 (1) , YK2 (2 ) , YK2 (3 ) , YK2 (4 ) , YK2 (5 ) ,YK2 (6 ) , YK2 (7 ) /50 . 2982STA  350 
$33,-11.395210,6.0537922,1.1542370,-9 .8051279E-4, 5 . 5609437E-6 , 1 . 458STA  360 


$4433E-8/ , CONK/1 .959964/ 

STA 

370 

DATA  ZERO/0 .0/ , ONE/1 .0/ , TWO/2 .0/ 

STA 

380 

IF  (L2.EQ.1.0R.NARGS.NE.1)  GO  TO  5 

STA 

385 

CALL  ERROR  (236) 

STA 

387 

RETURN 

STA 

390 

5 

DO  10  1=1,60 

STA 

395 

10 

A(I)=0.0 

STA 

400 

NXC0L=IARGS(1) 

STA 

410 

NXWT=IARGS(2) 

STA 

420 

IST0RE=1 

STA 

430 

NAR=NARGS 

STA 

440 

IWT=1 

STA 

450 

IF  (NARGS.EQ.l)  GO  TO  30 

STA 

460 

IF  (NARGS .EQ . 3 . AND . I ARGS (NARGS) . LT . 0 )  GOTO 

20 

STA 

470 

GO  TO  40 

STA 

480 

20 

NARGS=NARGS-1 

STA 

490 

IWT=2 

STA 

500 

30 

IST0RE=2 

STA 

510 

GO  TO  50 

STA 

520 

40 

IF  (NARGS .NE .2 .AND .NARGS .NE .3 .AND .NARGS .NE .5 

.  AND. NARGS .NE. 6) 

CALL  STA 

530 

1ERR0R  (10) 

STA 

540 

50 

J=NARGS 

STA 

550 

CALL  CKIND  (J) 

STA 

560 

IF  (J.NE.O)  CALL  ERROR  (3) 

STA 

570 
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60 


70 


80 


90 
100 


110 


A  A  1   1      PUI/Prtl       /   1  \ 

CALL  LHKLUL    (J ) 

f  T  A      r  a  a 

STA  580 

T  P      /   |     kir     a  \     A  A  1  1      rnnflD      /  1  1  \ 

I  r    (J.Nt.O)    LALL  tKKUK  (11) 

f  T  A       f*  A  A 

STA  590 

1  r      /  M  D  II A  V  *  A     1  C     M C  \     A  A     TA     L.  A 

lr    (NKMAX  4  .  Lt . Nb )    bU    IU  60 

fTA      /  A  A 

b 1  A  600 

A  A  1  1      rDDAD      /  O  "1  A  \ 

LALL  tKKUK  (Z14) 

fTA       /  T  A 

STA  610 

D  C  T 1 1 D  M 

Kt 1 UKN 

C  T  A  /OA 

b 1  A  620 

T  C      /  M  C  D  D  A  D     M  C     A  \     DCTI  IDM 

lr    (NtKKUK . Nt . 0 )  RtTUKN 

f  T  A  /OA 

STA  630 

T  V  M  MDUAV 

f  X  A       /    A  A 

STA  640 

An \     MDMA Y 
A  ( 1  )  =INKMAa 

C  T  A    L  c  a 

b  1  A  650 

1/     T  A  D  A  C  /  1  \ 

K=l AKbb ( 1 ) 

C  T  A      /  /  a 

b 1  A  660 

m=  1 

C  T  A  Z7A 

b  1  A  670 

TC      /MAD     C  A     1     AD     MAD     C  A     L  \     A  A    TA  OA 

lr    (NAK  .  ty  .  3  .  UK  .  NAK  .  tU. .  6  )   bU   IU  80 

r  T  A  /OA 

STA  680 

M  7  VAJ  MDAIAV 

NZ,  W=NKMAA 

C  T  A      /  n  A 

STA  690 

C  1  III  A  A 

bUM=U . 0 

C  T  A      "7  A  A 

b 1  A  700 

CO  A 

bZ=0  . 

C  T  A     7  1  A 

b  T  A  710 

U/T     A  A 

C  T  A      7  O  A 

b 1  A  720 

ACM  AJIA/T  A 
AbUMW 1 =0 . 

fTA       "T  1  A 

STA  730 

n  A    7  a    T    i  Tvti 
U\J    1  U    1  =  1  ,  1  AIM 

C  T  A      *7  A  A 

b 1  A  740 

CA/T    O  \     DA  /  V  \ 

bA  ( 1 , Z )=KL (K ) 

C  T  A      7  C  A 

b 1  A  750 

CA/T     1\     1  A 

C  T  A     7  £  A 

b 1  A  760 

TCA  M  1  M 
1  J A ( I  ) =m 

C  T  A    7  7  A 
b  1  A    /  /  U 

CA/T     1\  DA/l/\ 

bA  ( 1  , 1 )=KL (K ) 

c  T  A     7  nn 

STA  780 

\=l\+l 

fTA       -r  A  A 

STA  790 

M=IVI+1 

fTA  AAA 

STA  800 

n  1  =n  1  +JL  . 

C  T  A  OTA 

b  1  A  810 

CI  IU— CI  IM  ■  CA/T    7  \ 
OUlVI=oUIVI+oA  (  1  ,  i.  ) 

C  T  A     O  O  fi 

b 1  A  8^0 

ACM  MUIT    A  C  1 1 MU/T  ,  ADC  /  CA/T     O  \  \ 

AoUMW  1  =AbUMn  1  +Abb  (  bA  ( 1  ,  Z  )  ) 

C  T  A     a  o  a 

b 1  A  830 

CO    Co. CA/T    O  \  *  *  o 

b£=b<d+bA  (1  ,2)  2 

fTA  AAA 

bTA  840 

CIIMUIT  CUM 

bUMn 1 =bUM 

fTA  OCA 

b 1  A  850 

A  A    TA     1  1  A 
bU     1  U  111) 

fTA      O  L  A 

b 1  A  860 

C  1  1  M  A 

bUM=U  . 

fTA  OTA 

b 1  A  870 

U/T  A 

fTA       O  O  A 

STA  880 

CIIMU/T    A  n 
oUmll 1 =U . U 

C  T  A  AAA 

S 1  A  87O 

MA     TADAC  ni 

MA=1 AKbb ( Z ) 

fTA  AAA 

b 1  A  900 

CO     A  A 

bZ=U . 0 

fTA  ATA 

b 1  A  910 

T  U/T  O 

1  W  1  =2 

C  T  A     A  O  A 

b 1  A  9Z0 

Air  p  u/T  A 
Neb W 1 =0 

fTA       A  O  A 

b  1  A  930 

A  C  1  1  AIU/T  A 

AbUMW 1 =0 . 

fTA  AAA 

S  1  A  940 

nn    1  A  A     T     1     T  V  M 

UU   100    1  =  1 , 1  AN 

C  T  A     A  C  A 

S  1  A  950 

TC      /DA/UA\     CA     A     \     rn     TA  OA 

lr    ( Kb  ( MA )  .  tlj  .  0  .  )   bU    IU  90 

C  T  A     Q  L  A 

b 1  A  960 

tc   i  or  i  ma  \   it  n  n\  wcr  u/T  wcr  u/t  i  i 
1 r    ( KL ( MA )  . L 1  .  U  .  U )    Ntonl =Ntbn 1 +1 

C  T  A    Q  7  A 
b  1  A    9  /  U 

CA/M    0\     DC  1 V \ 
iA (M, Z )=KL (K ) 

C  T  A     Q  Q  A 

b  1  A  9oU 

CA/U    1 \     DA/ MA \ 

bA (M, 3 )=KL (MA ) 

C  T  A  AAA 

b 1  A  990 

TCA / M \  M 
1 bA ( M) =M 

C  T  A  1  AAA 
b 1 A1U00 

CA/M    "l\     DA  IV  \ 

bA (M, 1 )=KL (K ) 

C  T  A  1  AT  A 

b I A1U1U 

CO    CO. CA/M  0\**0*DA/MA\ 
bZ=bZ+bA (M,Z)ZKL (MA ) 

C  T  A  1  A  O  A 

C 1 1 M  CI  1 M  ,  D C  IV  \ 

bUM=bUIVI+KL  ( r\  ) 

C  T  A  1  A  "J  A 
b 1 AlO^U 

U/T     U/T  .  D  A  /  MA  \ 

W 1 =W 1 +KL ( MA ) 

C  T  A  1  A  A  A 

b I  A 1 040 

C  1 1 MUIT    CA/M    0  \  *  DP  /  MA  \  .CM  MUIT 

bUMn  1  =bA  ( M ,  Z  )    KL  ( MA  )  +  bUM»?  1 

C  T  A  1  A  C  A 

b  1  AJ.05U 

ACM  IIIA/T      ACM  IJU/T      ADC   (  C  A   /II     O  \  \  #  D  A  /  IIA  \ 

AbUMWT=AbUMWT+ABb (bA(M,2) )   Kb (MA) 

f  T  A  T  A  L  A 

b 1 A1060 

ii  ii  i 

M=M+1 

C  T  A  1  A  7  A 

b  1  A1070 

K=K+1 

C  T  A  1  A  Q  A 

b 1 AlUoU 

II A      II A  1 

MA=MA+1 

C  T  A  1  AAA 

b 1 A1090 

L|7Uf    M  -1 

NZW=M-1 

C  T  A  1  1  A  A 
b 1 A11U0 

TP      /  II C  A IA/T    AT     A\     AAII      CDDAD      /  O  O  5  \ 

lr    (NtbWT.bi.0)   CALL  tKKUK  (ZZ3) 

C  T  A  1  1  1  A 
b 1 A1110 

TC      /  II  7  tAI    AT     A\      AA     TA     1  1  A 

IF   (NZW.GT.0)  GO  TO  110 

C  T  A  1  1  OA 

b 1 A11Z0 

AAI  1      CDDAD      /  1 1  A  \ 

LALL  tKKUK  (ZZ4) 

C  T  A  1  1  1  A 

b 1 Al 130 

D  C  T  M  D II 

Kt 1 UKN 

C  T  A  1  1  A  A 

b 1 Al 14U 

A  /  0  \  —N7W 

O  1  nil JU 

A(3)=SUM/A(2) 

STA1160 
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A  1  A  \  — CI  IMWT  /  HUT 

STA1170 

b 1 Al 180 

M  1^3  |  =r                 10  .  A(Z)-Z7.)/7U.) 

b 1 Al 190 

i  not  Co 

A  ( J  7  )=bZ 

STA1200 

A  /  45  \  _ACI  IMU/T 

b 1 A1Z10 

A  (1j  ]  =AbUIVIW  1  /  V»  1 

f  T  A  1  AAA 

STA1220 

T  YM— M7U/ 
1  AN=N£W 

f  T  A  1  A  1  A 

STA1230 

TYMM1—TYM  1 
1ANI»I1  =  AAN  — 1 

CTA  1  A  A  A 

b 1 A1240 

T  CT— n 

fTI  1  A  C  A 

b 1 A1250 

nn  i  ^n  T— o  t ym 

C  T  A  1  1£(1 

b  1  A1Z60 

TP   /cam  i   i  i   ic  cam   i\\  pn  Tn  Tin 
1  r           \  1—  1  , 1  )  .  Lt  .  OA  ( 1  , 1  )  )    bU    1U  lJU 

C  X  A  1  ATA 

bTA1270 

h'  — T  CAM    1  \ 

C  T  A  T  AAA 

b  1  A1280 

IjH^l— 1 )=1 DM ( 1 ) 

C  T  A i inn 
b  1  A1Z90 

i  jfl  \  a  )  =r^ 

C  T  A  1  1  A  A 

b  1  A1300 

T— C A  M    1    1  \ 

C  T  A  1  i  1  n 

b 1 A1310 

CAM    1    1  \  — C  AM    1  l 
jA I 1 — 1 , 1 )=3A ( I , 1 ) 

C  T  A  1  1  o  n 

b 1 A13Z0 

CAM    1  \  T 
bA ( 1 , 1 )=l 

C  T  A  1  *5  O  A 

STA1330 

T  CT_1 
1  o  1  =1 

f  Til  A  4  A 

b I A1340 

rnwT  t  mi  ip 
Lun i l nul 

C  T  A  1  OCA 

b  1  A1350 

TP   mct  MP  m  Gn  Tn  ion 

lr     (  1  J  1  .WL  .  U  )    uU    1  U    1  £  U 

C  T  A  1  1  L  n 

MAI  DMA       1  C  *  A  i  ">  \ 

NALr HA= . £ D  A(Z; 

f  TA  1  O  "7  A 

b  1  A1370 

TYA    MAI  DUAM 
I  AA=NALr HA+1 

C  X  A  1  O  A  A 

5TA1380 

TYMA     TYM    MAI  DUA 
1  ANA=1  AN— NALr HA 

C  T  A  1  O  A  A 

b 1 A1390 

TCIIM_ft 
1  oUI»l=U  . 

b 1 A1400 

TIMCIIM— n 

C  T  A  1  A  1  A 

b 1 A141U 

1  W  1  =u 

C  T  A  1  it  A  A 

b 1 A14Z0 

nfl    1  An    T     TYA  TYMA 
UU    14U  A=1AA,1ANA 

C  T  A  1  A  1  n 

b 1 A1430 

M— t  am 

IW=  I  JA  \  I  ) 

C  T  A  1  A  a  n 

b 1 A1440 

TUiC  1 IM— TWCI IM  ■CAM    1\*CA/M  51 
1  noUIV^  1  nDUNH-  1A  (1  ,l)  bA(NI,j) 

C  T  A  1  /l  c  n 

b 1 A1450 

TVUT—TVUT^C A l M  It 
1 ni=l nl +jh (m , j ) 

C  T  A  1  A  l.  n 

b 1 A146U 

TCIIM—  TCIIMiCA  M    l  t 
1  jUW=  1  jUIVI+jA  (  I  ,  1  ) 

CT  A  1 A7n 
b 1 A14 / U 

A  /  7  \  — T  C||l»;  /  A  i  ■)  \    9  *PinAT/MAIDUA\\ 

c  T  A  i  a  o  n 
b 1 A148U 

A  I  ft  \  —  T  U/C 1 1 M  /  T  WT 
A  (o)  =  l  njUIYl/  1  If  1 

CT  A  1  A  Q  ft. 
b 1 A147U 

M  9—  /  M7UI  M  \  /  0 
n  £.=  ( NZ.W+1  )  i  C. 

CT  A i c n  n 
b 1 A13UU 

A  /  C  \  — C A  1  tiO    1  1 

CTA l ci n 

tp  /  Mn  n  /  m  7  uu  o  \  Pn  c\\  a  ict  f  a  /  c  \  i  c  a  /mom  i\\/t  vun 

ir    ^  muu  i  nz.  w ,  £  j  . ny  .  u ;    A  (  3  )  =  (,  A  (  3  J  +3A  ^  N&+1  ,  1  J  J  /  1  nil 

CT  A i con 

b  1  A  i  D  i.  U 

A  1 L  \      /CAM     1\,CAMYM    1\\/T  Wf\ 
A (0  ]  =  ( iA ( 1 , 1 ) +bA ( 1  AN  ,  1  j  )  /  1  HU 

C T A  i  cm 
b 1  Alb JO 

*  /  I  1  i     CAMYM    1  1     CAM     1  \ 

A  ( 1 1  )=>A  (  1  An  ,  J.  J  —  3 A  (  i  ,  i  ) 

CTA  i  cv!  n 
b 1 A1D4U 

A  I  1  A  \     CA/1  1\ 

A (^4 )=bA (1,1) 

C  T  A  i  c  c  n 
b 1 AlDDU 

A  / 1  <;  1  — C A  /  TYM    1  \ 
A \ 3 3 ; =3A ^ 1  AN , i ) 

CTA l  cifl 

nciv   a  n  i  \  fin 
V LL A=A ( 1 1 ) / 1 U . 

CT  A  1  C  7  n 

b 1  AID / U 

VD     CA  M  1\ 
AD=bA (1,1) 

C  T  A i con 
b  1  A1580 

V  T    VD  . nci  V 
A  1 =Xb+UtL A 

c  T  A i con 
b  1  AlDTU 

L=l 

C  T  A  i  £  n  n 
b 1 A1600 

UU   170   1=1 , 10 

C  T  A  1 L  \  n 

b 1 A1610 

TP  n 
1  L=0 

CT  A  1 L o  n 
b 1 A16ZU 

rr     /CA/I      1\    PC    VT\    pn    TH    1  L  n 

lr    ( bA ( L , 1 )  .  bt  .XI)    bU    IU  160 

C  T  A  1  tin 

b 1 A1630 

TP     T  P  .  1 
1 b=I b+1 

C  T  A  1  AAA 

b 1 A164U 

1  1.1 

L=L+1 

C  T  A  1  L  C  ft 
b 1 AlODU 

tp   i\    mp  tym\  pn  Tn  i  cn 

Ir     (L.Nc.lAN)    bU    IU  13U 

CTA 1  A Art 

A(l+DU)=lly 

CTA 1 t7fl 

vt  vt  .  nci  Y 

A  1 =A 1 +UtLX 

CT  A 1 L Q ft 
b 1 AlOOU 

TC     /I      /^T     T  Vkl  \     1*  f\    Tf\  inn 

IF    (L.bl.IXNj   bU  lu  1V0 

CT  A  1  ton 
b 1 A16V0 

np    ion    t    i     t  VM 
UU   180   1=L , 1 XN 

CTA 17  00 
b 1 Al / UU 

tc    /ca/t    i\    r c   vt  nn  v\    a  / l n \    a  /  l n  \  .  i 
lr    (bA ( 1 , 1 ) . bt . X 1 -UtLX )   A (60 )=A (60 )+l . 

CTA 17  1ft 
b 1 Al / IU 

P  rt  U  T  T  Al  1  1 C 

UUN 1 INUt 

CTA  1  70(1 
b  1  Al  /  C<J 

nn   inn    t    i  tvaiui 
UU   ZOO    1=1 , I XNM1 

CTA1  71(1 
j  1 Al f  JU 

SA ( I , 3 )=SA ( 1+1 , 1 ) -SA ( I ,1) 

C  T  A  1  7  A  ft 

b 1 Al 740 

LA=1 

STA1750 
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210 


220 


230 


240 
250 


260 


270 
280 


DO  210  1=1, IXN 

K=ISA(I) 

SA(K,1)=LA 

LA=LA+1 

K=0 

RNS=0 . 

RNSS=ONE 

LR=0 

DO  250  1=1 , IXNM1 

IF   (SA (I ,3 ) .NE.O.O.AND.K.EQ.O)  GO  TO  240 

IF   (SA ( I ,3) .NE.O.O)  GO  TO  220 

RNS=RNS+RNSS 

K=K+1 

GO  TO  250 

K=K+1 

RNS=RNS+RNSS 

RNS=RNS/FLOAT (K) 

DO  230  L=1,K 

LR=LR+1 

LRR=ISA(LR) 

SA(LRR,1)=RNS 

LR=LR-1 

RNS=0. 

K=0 

LR=LR+1 

RNSS=RNSS+ONE 

ICI=0 

IPLUS=0 

IMINUS=0 

IDRUNS=0 

IC=0 

ADEV=0.0 

DEV3=0.0 

DEV2=0 .0 

DEV=0.0 

DEVI=0.0 

DEVWT=0. 

DEV4=0.0 

AK=1. 

KWT=IARGS(2) 

NRXX=KWT+NRMAX-1 

TA=1.0 

DO  320  1=1 , IXN 

T=SA(I ,2)-A(4) 

SA(I,3)=T 

DEV=T+DEV 

ADEV=ADEV+ABS(T) 

DEV2=DEV2+T**2 

DEV3=DEV3+T**3 

DEV4=DEV4+T**4 

DEVI=AK*T+DEVI 

AK=AK+1.0 

IF  (IWT.EQ.l)  GO  TO  280 

IF  (RC(KWT) .NE.O.)  GO  TO  270 

IF  (KWT.GE.NRXX)  GO  TO  290 

KWT=KWT+1 

GO  TO  260 

TA=RC (KWT) 

DEVWT=DEVWT+TA*T**2 


STA1760 

STA1770 

STA1780 

STA1790 

STA1800 

STA1810 

STA1820 

STA1830 

STA1840 

STA1850 

STA1860 

STA1870 

STA1880 

STA1890 

STA1900 

STA1910 

STA1920 

STA1930 

STA1940 

STA1950 

STA1960 

STA1970 

STA1980 

STA1990 

STA2000 

STA2010 

STA2020 

STA2030 

STA2040 

STA2050 

STA2060 

STA2070 

STA2080 

STA2090 

STA2100 

STA2110 

STA2120 

STA2130 

STA2140 

STA2150 

STA2160 

STA2170 

STA2180 

STA2190 

STA2200 

STA2210 

STA2220 

STA2230 

STA2240 

STA2250 

STA2260 

STA2270 

STA2280 

STA2290 

STA2300 

STA2310 

STA2320 

STA2330 

STA2340 
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290 


300 


310 


320 


325 
326 


330 


340 


t  f        I  T      IT      A      A  \       A  A      T  f\      *\  f\  f\ 

IF  (T  . LT . 0 . 0 )  GO  TO  300 

STA2350 

T  ni   II  C      T  f"i  1   II  f  i 

IPLUS=IPLUb+l 

STA2360 

T  A  T  1 

ICI=+1 

STA2370 

GO  TO  310 

STA2380 

T  hi  T  HI  1  1  C       T  fcJ  T  HI  1  I  C  1 

IMINUb=IMINUS+l 

STA2390 

TAT  -i 

I C I =—1 

STA2400 

▼  A        /  T  A      r  f\       T  A  T  \       A  A      T  A      •»  A  A 

IF  (IC.EQ.ICI)  GO  TO  320 

STA2410 

I C= I C I 

STA2420 

IDRUNS=IDRUNS+1 

STA2430 

1/  IA/T     1/  UJT  .  1 

KWI=KWI +1 

STA2440 

A   /  1  1  \       nrW  HIT  /   /A/Ox       1  v 

A ( 13 )=DEVWT / (A (2 ) -1 . ) 

STA2450 

A  /  A  \     CCADT  /  A  /  1  1  \  \ 

A (V )=rbQK 1  (A  ( 13  )  ) 

STA2460 

A  /  1  A  \      A  /  A  \   /TCADT  /  UJT  \ 

A ( 10 )=A (9 ) /rbQKI (Wl ) 

STA2470 

A    /  1   A  \        1  A  A       *  A    /  O  \     /  A    /  A  \ 

A  (14) =100 .A (9) /A(4) 

ATA   a.  AAA 

STA2480 

A  /  A  A  \      T  ni  nc 

A (28 )=IPLUb 

STA2490 

A(29)=IMINUS 

A  T  A  A  ^  A  A 

STA2500 

A  /  1  1  \      1      .  /  1  #A/'1>0\+A/*lA\/A/0\\ 

A  ( 3 1 )=1 .+(2 .A(Zo)A(29) /A(2) ) 

A   /  O  A  \       CCADT//A  #A/AO\stcA/AA\:fe/A 

A(32)=r5QRT((2.A(28)*A(29)*(2 

C  T  A  A  C"  1  A 

STA2510 

A  A    /  A  A  \  3k  A    /  A  A  \       A    /  A  A  \ 

.A(28)*A(29)-A(28)- 

A    /  *\  A  \    \    v     /    /    /  A    /  <"»  r\  \       A  T  A       at  A  a 

A (29) ) ) / ( (A (28) +STA2520 

1A(29) )**Z* (A(2)-l . ) ) ) 

C  T  A  A  C  1  A 

STA2530 

A(36)=(DEV3/A(2) )**2/ ( (A(2)-l . 

) /A(2)*A(13) )**3 

b  I  A2540 

A(37)=(DEV4/A(2) ) / ( (A (2 )-l . ) /A (2 ) *A (13) ) **2 

STA2550 

A ( j o ) =bUMn 1 

STA2560 

A  1  A(\  \—  nFVU/T 
n  (1U  )  =  UC.  V  W  1 

STA2570 

A(30)=IDRUNS 

CTAicon 

A  /  111       /  A  /  1ft  \     A  (11  M  /  A  /  1  9  \ 

A(.*.?)  =  (A(.JU)-A(.J1))/A(JZ) 

C  T  A  O  C  O  A 

A ( IV )=1Z .    Utv  1 / (A  (Z )  (A(Z)Z— 

1  •  )  ) 

C  T  A  A  Z  A  A 

5TA2600 

A (20)=FSQRT ((l./(A(2)-2.))*(12 

. *DEV2 / (A (2 ) * (A (2 ) ** 

2-1 . ) )-A(19)**2)STA2610 

1) 

A  T  A  A  /  A  A 

b 1 A2620 

A(21)=A(19) /A(20) 

C  T  A  A  /  OA 

bTA2630 

A  A  1     1         A  A  A  A         /  Alir        a    /  <-t   \        Aiir        n     ,  n  i  ,4; 

CALL  PR0B  (0NE,A(2)-0NE ,A(21)* 

A(21) ,A(22) ) 

STA2640 

ATI-  /s 

D I  F=0 

STA2650 

IRUN=1 

STA2660 

DO  325  1=2, IXN 

C  T  A  A  L  L  C 

5TA2665 

T  A       A  A    /  T       a  i       A  *    /  T       n       *\  \ 

TA=SA(I ,2)-SA(I-l ,2) 

C  T  A  A  t  T  A 

5TA2670 

IF(TA)  326,325,326 

C  T  A  A  L  T  C 

STA2675 

CONTINUE 

A  T  A  A  y  A  A 

STA2680 

A  A      *»  O  A       T       A  TX/AI 

DO  330  1=2, IXN 

f  T  A  A /  AC 

STA2685 

T=SA(I ,2)-SA(I-l,2) 

A  T  A  A  /  A  A 

5TA2690 

DIF=DIF+T**2 

ATA  A  T  A  A 

STA2700 

IF  (TA*T.GE.0.0)  GO  TO  330 

C  T  A  A  T  1  A 

STA2710 

TA=T 

C  T  A  A  A"  A  A 

bTAZ720 

IRUN=IRUN+1 

A  T  A  A  T  O  A 

bTA2730 

CONTINUE 

b 1 AZ740 

A(23)=IRUN 

CTA07CA 

b 1 AZ / bU 

A(26)=DIF/(A(2)-1.) 

CT  A  9  7  Afl 
b 1  At / OU 

A(27)=A(26) /A(13) 
A(41)=A(4)*FSQRT(WT) /A(9) 

CT  A  0 7  7  n 
b 1  At /  / U 

CT  A  0  7  Q  f» 
b 1 AZ / OU 

A(12)=ADEV/A(2) 

STA2790 

NU=NZW-1 

ATA  A  A  A  A 

STA2800 

VNU=NU 

f*  T  A  A  A  1  A 

STA2810 

T=ZER0 

CTAIQ^A 

b 1 AZ8Z0 

TK1=ZER0 

CTA161A 

b 1 AZ830 

TK2=ZER0 

b 1 AZ840 

IF  (NU.GE.5)  GO  TO  350 

C  T  A  A  A  C  A 

STA2850 

DO  340  1=1,4 

CT  A  0  Q  A  ft 

b 1 AZooU 

V=I/NU 

CT A9  fl7  ft 
O 1 Ato / U 

T=T+BC0N(I)*V 

CT A  0 Q Oft 
b 1 AtOOU 

TK2=BKC0N(I)*V+TK2 

CTAOQQft 
O 1 H4O7U 

TK1=TK1+AKC0N(I)*V 

STA2900 

296 


GO  TO  400 

STA2910 

350 

T=(  (  ( (AT5 (6) /VNU+AT5 (5) ) /VNU+AT5 (4) ) /VNU+AT5 (3) ) /VNU+AT5 (2) ) /VNU+ASTA2920 

115(1) 

C  T  A  9  Q  1  n 
O  1  A  A  7  J  U 

tc    /mm  n   i  n  \    r  n  th 

1  r    (NU.bl.10)    bU    IU  3/0 

C  T  A  9  O  A  A 
b 1 AA74U 

ri  a   i  l  f\    t    i  ' 
UU   360    1=1 , 0 

C  T  A  9  O  C  A 
b 1 AA7DU 

V/         ,    T        A    \  /Mil 

V= ( 1 +4 ) /NU 

C  T  A  9  A  L  A 

b 1 A2960 

1  M  =  1  M+LM  (1  )  V 

C  T  A  9  A  7  A 
b 1 AA7 / U 

360 

Tl/  9    TI^O  .  TWO  /  T  \  #*Vl 

1  KZ=  1  Ka+UKa  ( 1  )  V 

C  T  A  9  O  O  A 
b 1 AA700 

bU    1 U  4U0 

C  T  A  9  O  A  A 
b 1 AA77U 

i  t  rt 
370 

tc   /mii  n  inni  rn  m  ion 
lr    (INU.bl  .1UU)    bU    IU  J7U 

c  t  a  i  n  n  n 
b l A JUUU 

n  n   i q a   t    i  7 
UU  3  80   1  =  1 , / 

C  T  A  "2  A  1  A 
b 1 A3010 

W     \/  M  1  1  *  *  /  T     A  \ 

V=VNU      ( 1 -4 ) 

C  T  A  1  A  9  A 

b 1 A30Z0 

1  In  1=1  M+AM  (  I  )  V 

b  1  A  }\)}\J 

ion 

380 

TI//9  TI//9.VI//9/T\*W 
ll\A=lr\A  +  Tr\A  (1  J  V 

b 1  A JU4U 

art  to  Ann 

UU     1 u  HUU 

QT  A  n  c.  n 

i  o  a 
390 

\/9    CCnDT  /  TU/n*  WMI 1  1 

Vi=r  j(JK  1  (1  wu  vnu  ) 

C  T  A  1  A  A  A 

b 1 A3060 

\/9M1     CCnDT  /  TU/n  *  WMI  1    DIUP  t 

v  ^  ivii=r  du.k  i  ( i  wu  vnu— uiMt) 

C  T  A  7  A  7  A 

b  1  A  .5  U  /  U 

Tkl  —  V9  1  (^nillk  iUOMl  1 
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STA3470 

WRITE  (IPRINT,750) 

STA3480 

IF  (IWT.EQ.l)  GO  TO  460 

STA3490 
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460 
470 


480 


490 


500 
510 


520 
530 

540 


550 
560 


570 


580 


590 


WRITE  (IPRINT  ,760) 
GO  TO  470 

WRITE  (IPRINT, 770) 
K=ISA(I+1) 
TA=SA(K,2)-T 
GO  TO  (500,480) ,  IWT 
IF  (RC(LW) .NE.O.O)  GO  TO  490 
LW=LW+1 
GO  TO  480 
WRITE  (IPRINT, 790) 
LW=LW+1 
GO  TO  510 
WRITE  (IPRINT, 780) 
T=SA(K,2) 
LINE=LINE+1 

IF   (LINE. NE. 10)  GO  TO  520 
LINE=0 

LINEP=LINEP+10 
WRITE  (6,800) 
CONTINUE 

(IWT.EQ.l)  GO  TO  550 


I ,SA(I ,2) ,SA(I ,1) ,SA(I ,3) ,RC(LW) , ISA ( I ) ,T ,TA 


I,SA(I,2)(SA(I,1),SA(I,3),ISA(I),T,TA 


STA3500 
STA3510 
STA3520 
STA3530 
STA3540 
STA3550 
STA3560 
STA3570 
STA3580 
STA3590 
STA3600 
STA3610 
STA3620 
STA3630 
STA3640 
STA3650 
STA3660 
STA3670 
STA3680 
STA3690 
STA3700 
STA3710 
STA3720 
STA3730 

) ,RC(LW) ,ISA(NZSTA3740 
STA3750 


600 
610 


IF 

IF   (RC(LW) .NE.O.O)  GO  TO  540 
LW=LW+1 
GO  TO  530 

WRITE  (IPRINT, 790)  NZW , SA (NZW, 2 ) , SA (NZW, 1 ) , SA (NZW, 3 
1W),T 

GO  TO  560  STA3760 

WRITE  (IPRINT, 780)  NZW, SA (NZW, 2 ) , SA (NZW, 1 ) , SA (NZW, 3 ) , ISA (NZW) ,T  STA3770 

IF  (IST0RE.EQ.2)  RETURN  STA3780 

IF  (NARGS.EQ.2 .OR.NARGS .EQ.3)  GO  TO  570  STA3790 

L=IARGS (NARGS-3 )  STA3800 

M=IARGS (NARGS-2 )  STA3810 

K=IARGS (NARGS-1 )  STA3820 

J=IARGS (NARGS )  STA3830 

GO  TO  580  STA3840 

L=IARGS (NARGS)  STA3850 

M=L+NROW  STA3860 

K=M+NROW  STA3870 

J=K+NROW  STA3880 

DO  590  1=1, NZW  STA3890 

MB=ISA(I)  STA3900 

RC(K)=SA(MB,2)  STA3910 

RC(M)=SA(I ,1)  STA3920 

RC(J)=SA(I,3)  STA3930 

M=M+1  STA3940 

K=K+1  STA3950 

J=J+1  STA3960 

IF  (NZW.EQ.NRMAX)  GO  TO  610  STA3970 

NZW1=NZW+1  STA3980 

DO  600  I=NZW1,NRMAX  STA3990 

RC(M)=0.  STA4000 

RC(K)=0.  STA4010 

RC(J)=0.  STA4020 

M=M+1  STA4030 

K=K+1  STA4040 

J=J+1  STA4050 

NT0P=60  STA4060 

IF  (NROW.LT.NTOP)  NTOP=NROW  STA4070 

DO  620  I=1,NT0P  STA4080 
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620 


630 
C 

640 
650 

660 

670 

680 
690 

700 


710 


720 


730 


740 

750 
760 

770 

780 
790 
800 


RC(L)=A(I) 
L=L  +  1 

IF  (NRMAX.LT.60)  RETURN 

DO  630  I=61,NRMAX 

RC(L)=0. 

L=L+1 

RETURN 


STA4090 
STA4100 
STA4110 
STA4120 
STA4130 
STA4140 
STA4150 
STA4160 

I4,33X,4HN  =  ,14)  STA4170 
I4,8X,15HWEIGHTS  INSTA4180 

STA4190 

I4,8X,15HWEIGHTS  INSTA4200 
1  COL  ,I4,6X,4HN  =  ,I4,33H(N0  OF  NON-ZERO  WTS)  COL  LENGTH  =,14)  STA4210 
FORMAT  (1H0,24X,64HALL  COMPUTATIONS  ARE  BASED  ON  OBSERVATIONS  WITHSTA4220 


FORMAT 
FORMAT 


(1H0(4X,28HSTATISTICAL 
(1H0,4X,28HSTATISTICAL 
1  COL  ,I4,6X,4HN  =  ,14) 
FORMAT  (1H0  , 4X , 28HSTATI STICAL 


ANALYSIS 
ANALYSIS 


OF 
OF 


COL 
COL 


ANALYSIS  OF  COL 


(1-6) ,7X, 1016) 
2) ,34X,28HMEASURES 


1  NON-ZERO  WEIGHTS) 

FORMAT  (1H0/15X,28HFREQUENCY  DISTRIBUTION 

FORMAT  (1H0/5X,26HMEASURES  OF  LOCATION  (2- 
1SPERSI0N  (2-6)) 

FORMAT (1H0, 

1  9X,26HUNWEIGHTED  MEAN  =,  1PE15 

2  26HSTANDARD  DEVIATION  =,  E15 
310X,26HWEIGHTED  MEAN  =,  E15 
4        26HS.D.  OF  MEAN  =,  E15 
510X,26HMEDIAN  =,  E15.7 
6        26HRANGE                                  =,  E15.7 
710X,26HMID-RANGE                            =,  E15.7 
8        26HMEAN  DEVIATION                   =,  E15.7 
910X,26H25  PCT  UNWTD  TRIMMED  MEAN= ,  E15.7 
A        26HVARIANCE                             =,  E15.7 
B10X,26H25  PCT  WTD  TRIMMED  MEAN    =,  E15.7,20X, 
C        26HC0EFFICIENT  OF  VARIATION  =,  E15.7  ) 

FORMAT  (1H0//20X,50HA  TWO-SIDED  95  PCT  CONFIDENCE  INTERVAL 
IN  IS1PE11.4(3H  TO, Ell. 4, 6H  (2-2 ) /20X , 50HA  TWO-SIDED  95  PCT 
2NCE  INTERVAL  FOR  S.D.  IS, Ell. 4, 3H  T0,E11.4,6H  (2-7)) 


20X 


20X 


20X 


20X 


20X 


STA4230 
STA4240 
OF  DISTA4250 
STA4260 
STA4265 
STA4270 
STA4275 
STA4280 
STA4290 
STA4295 
STA4300 
STA4305 
STA4310 
STA4315 
STA4320 
STA4325 
STA4330 
FOR  MEASTA4350 
C0NFIDESTA4360 
STA4370 


FORMAT  (1H0//5X,30HLINEAR  TREND  STATISTICS  (5-1)  , 30X , 16H0THER  STASTA4380 
1TISTICS//10X,5HSL0PE,20X,1H=,1PE15.7,20X,7HMINIMUM,18X,1H=,E15.7/1STA4390 
20X,13HS.D.  OF  SLOPE , 12X , 1H=, E15 . 7 , 20X , 7HMAXIMUM, 18X , 1H= , E15 . 7 /10X , STA4400 
326HSL0PE/S.D.  OF  SLOPE  =  T  = , E15 . 7 , 20X , 8HBETA  ONE , 17X , 1H=,E15 .7 /1STA4410 
40X,35HPR0B  EXCEEDING  ABS  VALUE  OF  OBS  T  = , 0PF6 . 3 , 20X , 8HBETA  TWO , 17STA4420 
5X,1H=,1PE15 .7/71X.17HWTD  SUM  OF  VALUES , 8X , 1H= , E15 . 7 /71X , 18HWTD  SUMSTA4430 

6  OF  SQUARES, 7X , 1H=, E15 . 7 /5X , 24HTESTS  FOR  NON-RANDOMNESS , 42X , 26HWTDSTA4440 

7  SUM  OF  DEVS  SQUARED    =,E15.7/71X, 11HSTUDENT/S  T , 14X , 1H= , E15 .7)  STA4450 
FORMAT  (10X,26HN0  OF  RUNS  UP  AND  DOWN      = , 1 5 , 30X , 26HWTD  SUM  ABS0LUSTA4460 

1TE  VALUES    =,1PE15.7/10X,26HEXPECTED  NO  OF  RUNS  = , 0PF7 . 1 , 28X , STA4470 

226HWTD  AVE  ABSOLUTE  VALUES    = , 1PE15 . 7 /10X , 26HS . D .  OF  NO  OF  RUNS  STA4480 

3  =,0PF8.2/10X,26HMEAN  SQ  SUCCESSIVE  DIFF    =, 1PE16 . 7 / 10X , 26HMEANSTA4490 

4  SQ  SUCC  DIFF/VAR  = .0PF9 .3// /10X , 24HDEVIATI0NS  FROM  WTD  MEAN/ /1STA4500 
55X,21HN0  OF  +  SIGNS  =, I5/15X ,21HN0  OF  -  SIGNS  =I5/15X ,STA4510 
610HN0  OF  RUNS,10X,1H=,I5/15X,21HEXPECTED  NO  OF  RUNS  = , F7 . 1 / 15X , 12HSTA4520 
7S.D.  OF  RUNS, 8X,1H=,F8.2/15X,21HDIFF. /S.D.  OF  RUNS    =F9.3)  STA4530 

FORMAT  (/////68H  NOTE  -  ITEMS  IN  PARENTHESES  REFER  TO  PAGE  NUMBER  STA4540 
UN  NBS  HANDBOOK  91)  STA4550 

FORMAT  (//27X,12H0BSERVATI0NS,47X,20H0RDERED  OBSERVATIONS)  STA4560 

FORMAT  (1H0,8X,1HI ,9X,4HX(I) , 9X , 4HRANK , 7X , 9HX ( I ) -MEAN , 7X , 4HW( I ) ,16STA4570 
1X,3HN0. ,8X,4HX(J) , 10X , 11HX ( J+l )-X (J ) )  STA4580 

FORMAT  (1H0,8X,1HI,9X,4HX(I) , 9X ,4HRANK , 7X , 9HX ( I ) -MEAN , 27X , 3HN0 . ,8XSTA4590 


1,4HX(J) ,10X,11HX(J+1)-X(J) ) 
FORMAT  (I10,1PE17.7,0PF9.1,1PE17 
FORMAT  (I10,1PE17.7,0PF9.1,1PE17 
FORMAT  (1H  ) 
END 


7,22X,I6,1P2E17.7) 
7,1PE12.3,10X,I6,1P2E17.7) 
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STA4600 
STA4610 
STA4620 
STA4630 
STA4640 


SUBROUTINE  STMT  (NSTMT)  STM  10 

C         VERSION    5.00         STMT  5/15/70                                                    STM  20 
COMMON  /BLOCKA/  MODE , M,KARD (83 ) ,KARG ,ARG ,ARG2 , NEWCD (80) , KRDEND        STM  30 

C  STM  40 

C         THIS  SUBROUTINE  ASSEMBLES  AND  CHECKS  A  STATEMENT  NUMBER.  STM  50 

C  STM  60 

C         CALLED  BY. .     .MAIN.  STM  70 

MISC=10*KARD(M)  STM  80 

10        M=M+1  STM  90 

K=KARD (M)  STM  100 

IF  (K.GE.10)  GO  TO  30  STM  110 

MISC=10* (MISC+K)  STM  120 

IF   (MISC. LT. 10000)  GO  TO  10                                                                   STM  130 

C  STM  140 

C          ILLEGAL  STATEMENT  NUMBER  EXIT                                                               STM  150 

C  STM  160 

20        KARG=1  STM  170 

RETURN  STM  180 

C  STM  190 

C         NON-NUMERIC  FOUND,  IS  IT  A  .                                                                 STM  200 

C  STM  210 

30        IF  (K.EQ.37)  GO  TO  50  STM  220 

C  STM  230 

C          IS  IT  A  /  STM  240 

C  STM  250 

40        IF  (K.EQ.36)  GO  TO  70  STM  260 

C  STM  270 

C          IS  IT  A  SPACE  STM  280 

C  STM  290 

IF   (K-44)  20,60,20  STM  300 

C  STM  310 

C          .  FOUND,  MUST  BE  FOLLOWED  BY  ONE  AND  ONLY  ONE  NUMERAL  STM  320 

C  STM  330 

50        M=M+1  STM  340 

K=KARD (M)  STM  350 

IF  (K.GE.10)  GO  TO  20  STM  360 

MISC=MISC+K  STM  370 

60        M=M+1  STM  380 

K=KARD (M)  STM  390 

GO  TO  40  STM  400 

70        M=M+1  STM  410 

K=KARD (M)  STM  420 

C  STM  430 

C          /  FOUND,  MUST  BE  FOLLOWED  BY  BLANKS  THEN/OR  A  LETTER  STM  440 

C  STM  450 

IF  (K.EQ.44)  GO  TO  70  STM  460 

IF  (K.GE.36.0R.K.LT.10)  GO  TO  20                                                          STM  470 

C  STM  480 

C         LEGAL  STATEMENT  NUMBER  FOUND  STM  490 

C  STM  500 

NSTMT=MISC  STM  510 

KARG=0  STM  520 

RETURN  STM  530 

END  STM  540 
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SUBROUTINE  STORE  (J)  STO  10 

C         VERSION    5.00         STORE           5/15/70  STO  20 

COMMON  /BLOCKA/  MODE , M, KARD (83 ) , KARG , ARG , ARG2 , NEWCD (80 ) , KRDEND        STO  30 

COMMON  /BLOCKB /  NSTMT , NSTMTX , NSTMTH , NCOM, LCOM, IOVFL , COM( 2000 )  STO  40 

COMMON  /BLOCRC/  NRC  ,RC  (12600 )  STO  50 

COMMON  /BLOCKD/  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NSTO  60 

1ARGS , VWXYZ (8 ) ,NERROR  STO  70 

DIMENSION  ARGS(IOO)  STO  80 

EQUIVALENCE  (ARGS ( 1 ), RC ( 12501 ) )  STO  90 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG  STO  100 

C                STORAGE  LAYOUT..                  STATEMENT  NUMBER                                   STO  110 

C                                                           NUMBER  OF  WORDS  IN  ENTRY                     STO  120 

C                                                              NARGS+64*(L1+64*L2)  STO  130 

C         ALL  ITEMS  ARE  STORED  IN             (      ENTRY  1        )                                   STO  140 

C         FLOATING  POINT  TO  ALLOW             (  2        )                                   STO  150 

C         CONVERSION  TO  DOUBLE-    STO  160 

C         PRECISION.                                   (  LAST  WORD  )                                   STO  170 

C  STO  180 

IF  (IOVFL. NE.O)  RETURN  STO  190 

IZE=J+2  STO  200 

IF  (NSTMT. GT. NSTMTH)  GO  TO  90  STO  210 

C  STO  220 

C                STATEMENT  IS  AN  INSERTION  OR  A  REPLACEMENT  STO  230 

C  STO  240 

L=LOCATE (NSTMT)  STO  250 

IF  (L.GT.O)  GO  TO  30  STO  260 

C  STO  270 

L=-L  STO  280 

IDIF=IZE  STO  290 

10        LL=NCOM  STO  300 

C                STATEMENT  IS  AN  INSERTION,  OPEN  GAP  STO  310 

II=LL+IDIF  STO  320 

IF  (II. GE. LCOM)  GO  TO  100  STO  330 

DO  20  I=L,NCOM  STO  340 

COM(II)=COM(LL)  STO  350 

11=11-1  STO  360 

20        LL=LL-1  STO  370 

GO  TO  60  STO  380 

C  STO  390 

C                STATEMENT  IS  REPLACEMENT  STO  400 

C  STO  410 

30        IDIF=IZE-IFIX(C0M(L+1) )  STO  420 

IF  (IDIF)  40,60,10  STO  430 

C  STO  440 

C                NEW  STATEMENT  SMALLER  THAN  OLD,  CLOSE  UP  GAP.                              STO  450 

C  STO  460 

40        I=L-IDIF  STO  470 

II=L  STO  480 

DO  50  IA=I,NCOM  STO  490 

COM(II)=COM(IA)  STO  500 

50        11=11+1  STO  510 

C  STO  520 

C                INSERT  STATEMENT  STO  530 

C  STO  540 

60        COM(L)=NSTMT  STO  550 

C0M(L+1)=IZE  STO  560 

C0M(L+2)=NARGS+64*(L1+64*L2)  STO  570 

NCOM=NCOM+IDIF  STO  580 

IF  (IZE.EQ.3)  GO  TO  80  STO  590 
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409-118  OL  -  71  -  20 


DO  70  1=4 , IZE  STO  600 

C0M(L+3)=ARGTAB(I-3)  STO  610 

70        L=L+1  STO  620 

80        CONTINUE  STO  630 

RETURN  STO  640 

C  STO  650 

C  PUT  STATEMENT  ON  END  STO  660 

C  STO  670 

90        L=NCOM  STO  680 

IDIF=IZE  STO  690 

NSTMTX=NSTMTH  STO  700 

NSTMTH=NSTMT  STO  710 

IF  (NCOM+IDIF.LT.LCOM)  GO  TO  60  STO  720 

C  STO  730 

C  COM  STORAGE  OVERFLOW  STO  740 

C  STO  750 

100      I0VFL=1  STO  760 

CALL  ERROR  (12)  STO  770 

RETURN  STO  780 

END  STO  790 


SUBROUTINE  STORMT  (C , N , NP , K  ,  A )  STT  10 

C         VERSION    5.00  STORMT         5/15/70                                                    STT  20 

C         *  STT  40 

C         SUBROUTINE    STORES  MATRIX  C(NP,K  )  FROM    SCRATCH  AREA        A  STT  50 

C         *  STT  60 

DIMENSION  A(l)  ,  C(N,1)                                                                           STT  70 

IS=1  STT  80 

DO  10  J=1,K  STT  90 

DO  10  1=1, NP  STT  100 

C(I,J)=A(IS)  STT  110 

10        IS=IS+1  STT  120 

RETURN  STT  130 

END  STT  140 
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10 


20 


30 


40 


SUBROUTINE  STRUVE  (Z,A,B,C) 

STR 

10 

VERSION     5.00          STRUVE  5/15/70 

STR 

20 

DIMENSION  C(l) 

STR 

30 

DOUBLE  PRECISION  Z,A,B,C,X,P,Q,R,S, DBEJ 

STR 

40 

X=DABS(Z) 

STR 

50 

IF  (X.GT. .ODO)  GO  TO  10 

STR 

60 

A=.0D0 

STR 

70 

B=.0D0 

STR 

80 

GO  TO  40 

STR 

90 

IF  (X.GT. 70. DO)  GO  TO  30 

STR 

100 

CALL  BEJN  (0,C,X) 

STR 

110 

P=.ODO 

STR 

120 

Q=.ODO 

STR 

130 

DO  20  N=l,49 

STR 

140 

J=2*N 

STR 

150 

K=J+1 

STR 

160 

R=J-1 

STR 

170 

S=4*N**2-1 

STR 

180 

P=P+C(J)/R 

STR 

190 

Q=Q+C(K)/S 

STR 

200 

A=P/ .78539816339D0 

STR 

210 

B=(2 .D0*Q+1 .DO-C(l) ) /l .5707963268D0 

STR 

220 

GO  TO  40 

STR 

230 

S=l .D0/X**2 

STR 

240 

P=l .DO-S* (1 . DO-9 .DO*S* (1 .00-25 .D0*S* 

(1 .00-49 

DO*S)  ) ) 

STR 

250 

A=DBEJ (X,0,5)+P/ (X*l .5707963268D0) 

STR 

260 

Q=1.D0+S* (1.D0-3 .DO*S* (1 .DO-15 .D0*S* 

(1.D0-35 

DO*S) )  ) 

STR 

270 

B=DBEJ (X,l,5)+Q/ (1 .5707963268D0) 

STR 

280 

RETURN 

STR 

290 

END 

STR 

300 

SUBROUTINE  SYMV  (A,NROW,N,K) 

SYM 

10 

C 

VERSION    5.00  SYMV 

5/15/70 

SYM 

20 

C 

FOR  OMNITAB  WRITTEN  BY  S 

PEAVY  11/29/67 

SYM 

30 

C 

A-FIRST  ELEMENT  OF  MATRIX 

A 

SYM 

40 

C 

NROW  -NO.  OF  ROWS  IN  A  AS 

DEFINED 

IN  A  DIMENSION 

ST 

SYM 

50 

C 

N  -PRESENT  SIZE  OF  A 

SYM 

60 

C 

K  -STATUS  FOR  SYMMETRY 

SYM 

70 

C 

K=0  EXACT  SYMMETRY  A  A ( I , J ) / A ( J , I ) )=1 

SYM 

80 

C 

K=l  SYMM  TO  A  RELATIVE  RROR 

ABS  ( 1 

-A(I,J)/A(J,I)) 

=  OR  LESS  l.E-7 

SYM 

90 

C 

K=2  NO  SYMMETRY 

SYM 

100 

C 

SYM 

110 

DIMENSION  A(NROW,NROW) 

SYM 

120 

K=0 

SYM 

130 

NN=N-1 

SYM 

140 

DO  40  J=1,NN 

SYM 

150 

I=J+1 

SYM 

160 

DO  40  L=I ,N 

SYM 

170 

IF   (A(J,L))  20,10,20 

SYM 

180 

10 

T=ABS(A(L,J) ) 

SYM 

190 

GO  TO  30 

SYM 

200 

20 

T=ABS(1.0-A(L,J)/A(J,L)) 

SYM 

210 

30 

IF  (T.EQ.O.)  GO  TO  40 

SYM 

220 

K=l 

SYM 

230 

IF  (T.LE.l.E-7)  GO  TO  40 

SYM 

240 

K=2 

SYM 

250 

RETURN 

SYM 

260 

40 

CONTINUE 

SYM 

270 

RETURN 

SYM 

280 

END 

SYM 

290 
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SUBROUTINE  TAPOP  TAP  10 

C          VERSION     5.00          TAPOP            5/15/70  TAP  20 

C             RV    SUBROUTINE    USED  WITH  TAPE  COMMANDS  TAP  30 

COMMON  /TAPE/  NAME4 (2 ) ,NTPCT , IPUNCP , INUNIP , L1TP  TAP  40 

COMMON  /CODE/  I ALPH (6 ) , NALPH (5 ) , I D  (9  , 3 )  ,  I R  (300  , 4 )  ,  I RD  (30  ,  6  )  TAP  50 

C0MM0N/ABCDEF/L(48)  TAP  55 

COMMON  /BLOCKA/  MODE , M, KARD (83 ) , KARG , ARG , ARG2 , NEWCD (80 ) , KRDEND        TAP  60 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG  TAP  70 

COMMON  /CODETP/  ITP(10,4)  TAP  80 

NAME4(1)=0  TAP  90 

NAME4(2)=0  TAP  100 

NTPCT=0  TAP  110 

10        K=KARD(M)  TAP  120 

C         THE  TAPE  ID  MAY  BE  A  NUMBER  OR  A  LETTER  TAP  130 

IF   (K.LT.36)   IF(K-IO)  20,30,30  TAP  135 

M=M+1  TAP  140 

GO  TO  10  TAP  150 

20        ITAPE=KARD (M)  +6  TAP  160 

MP=M-1  TAP  170 

GO  TO  50  TAP  180 

30        MP=M-1  TAP  190 

CALL  NNAME  (NAME4 (1 ) )  TAP  200 

ITAPE=0  TAP  210 

DO  40  1=1,6  TAP  220 

IF   (NAME4 (1 ) .NE . I ALPH  ( I ) )  GO  TO  40  TAP  230 

ITAPE=I+6  TAP  240 

GO  TO  50  TAP  250 

40        CONTINUE  TAP  260 

50        IF(ITAPE.GT.9)  GO  TO  60  TAP  270 

KARD(MP)=L(45)  TAP  280 

KARD(MP+1)=ITAPE  TAP  290 

GO  TO  80  TAP  300 

60        KARD(MP)=1  TAP  310 

KARD(MP+1)=ITAPE-10  TAP  320 

C         CREAD        READ        WRITE  TAP  340 

80        IF  (NAME ( 1 ) .NE . ITP (2 , 1 ) .AND .NAME (1) .NE. I TP (1,1) .AND .NAME (1) .NE . ITPTAP  350 

1(3,1))  GO  TO  110  TAP  360 

NAME4(1)=0  TAP  370 

NAME4(2)=0  TAP  380 

M=M+1  TAP  390 

90        K=KARD (M)  TAP  400 

IF  (K.LT.36)  IF  (K-10)  110,100,100  TAP  410 

M=M+1  TAP  420 

GO  TO  90  TAP  430 

100      CALL  NNAME  (NAME4 (1) )  TAP  440 

110      M=MP  TAP  450 

RETURN  TAP  460 

END  TAP  470 
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SUBROUTINE  TAPOP2  TP2  10 

C         VERSION    5.00          TAP0P2          5/15/70  TP2  20 

C         THIS  SUBROUTINE  IS  NEDOED  ONLY  FOR  TAPE  OPERATIONS  TP2  30 

C          Ll=  45    L2=l,7  TP2  40 

C              READ  TAPE    A-F    A-F  (FORMAT)     INTO    COLUMNS  ++,++,++,++,  ETC.     TP2  50 

C              READ  UNTIL  A  RECORD  OF  A      ZEROS  ARE  ENCOUNTERED  TP2  60 

C              IF  NO  FORMAT  IS  GIVEN,  CARDS  ARE  READ  AS  IN  READ  COMMAND  TP2  70 

C          Ll=  46    L2=l,7  TP2  80 

C              CREAD  TAPE  A-F    A-F  (FORMAT)        CARDS  INTO    COLUMNS  ++,++,++,  ETP2  90 

C              CREAD  TAPE    A-F     , , CARDS  INTO  COLUMNS  ++,++,++, ETC .  TP2  100 

C              READ  USING  A  COUNTER  TP2  110 

C          Ll=  47     L2=l,7  TP2  120 

C              WRITE  TAPE  A-F  A-F (FORMAT)     FROM  COLUMNS  ++,++,++,++, ETC .  TP2  130 

C         A  RECORD  OF  ZEROS  IS  WRITTEN  AFTER  NRMAX  VALUES  TP2  140 

C          Ll=  48    L2=l  TP2  150 

C              SET  TAPE  A-F     INTO    COLUMNS  ++  TP2  160 

C              SET  TAPE  A-F     INTO    ROW       OF  COLUMN  ++  TP2  170 

C         READ  UNTIL  A  RECORD  OF  ZEROS  IS  ENCOUNTERED  TP2  180 

C          Ll=  49      L2=l  TP2  190 

C              CSET  TAPE  A-F  ,,  VALUES  INTO  COLUMN  ++  TP2  200 

C              CSET  TAPE  A-F  ,,  VALUES  INTO  ROW  ,,  OF  COLUMN  ++  TP2  210 

C             READ  USING  A    COUNTER  TP2  220 

C          Ll=  50      L2=l  TP2  230 

C              ENDFILE    TAPE    A-F  TP2  240 

C          Ll=50    L2=2  TP2  250 

C              REWIND    TAPE    A-F  TP2  260 

C          Ll=  50    L2=3  TP2  270 

C              SKIP  TAPE    A-F    FORWARD         RECORDS  TP2  280 

C          Ll=  50    L2=4  TP2  290 

C              BACKSPACE  TAPE  A-F  ,,  RECORDS  TP2  300 

COMMON  /BLOCKC/  KIO , I  NUN  IT , ISCRAT , KBDOUT , KRDKNT , LLIST  TP2  310 

COMMON  /BLOCKD /  I ARGS ( 100 ), KIND ( 100 ) ,ARGTAB ( 100 ), NRMAX , NROW, NCOL , NTP2  320 

1ARGS,VWXYZ(8) ,NERROR  TP2  330 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , ISRFLG  TP2  340 

COMMON/ HEADER /NOCARD (80 ) ,ITLE(60,6) , LNCNT , I  PR  I NT ,NPAGE , I  PUNCH  TP2  350 

COMMON  /SCRAT/  NS  ,NS2  ,A (13500 )  TP2  370 

COMMON  /TAPE/  NAME4 (2 ) ,NTPCT , IPUNCP , I NUN  IP , L1TP  TP2  380 

C         CHECK  FOR  CORRECT    NUMBER  OF  ARGUMENTS  TP2  390 

IF(L1.LT.50)  IF(NARGS-2)  5,30,30  TP2  395 

GO  TO  (10,10,20,20),  L2  TP2  400 

5         CALL  ERROR  (10)  TP2  410 

GO  TO  30  TP2  420 

10        IF  (NARGS.NE.l)  CALL  ERROR  (10)  TP2  430 

GO  TO  40  TP2  440 

20        IF  (NARGS.NE.2)  CALL  ERROR  (10)  TP2  450 

C         ALL  ARGUMENTS  SHOULD  BE  INTEGERS  TP2  460 

30        J=NARGS  TP2  470 

CALL  CKIND  (J)  TP2  480 

IF  (J.NE.O)  CALL  ERROR  (3)  TP2  490 

C         IS  TAPE  NUMBER  CORRECT  TP2  500 

40        IF  (IARGS(l) .LT.7.0R.IARGS(1) .GT.12)  CALL  ERROR  (28)  TP2  510 

IF  (NERROR . NE . 0 )  RETURN  TP2  520 

LlP=Ll-44  TP2  530 

GO  TO  (50,70,90,60,80,170),  LIP  TP2  540 

50        IF  (L2.EQ.1)  GO  TO  60  TP2  550 

INUNIT=IARGS(1)  TP2  560 

IARGS(1)=0  TP2  570 

GO  TO  130  TP2  580 

60        IA=2  TP2  590 
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A  A      T  A      i  ft  A 

GO  TO  100 

TP2  600 

70 

T  C       /  t    A      MC      1   \      A  A     T  A      L  A 

IP    (L2 . Nt . 1 )   bU    1 U  60 

T  A  A      /  T  A 

TP2  610 

80 

Al  T  A  A  T      T  A  D  A  C /  A  \ 

NTPCT=I ARGb (2 ) 

T  A  A      /  A  A 

TP2  620 

T  A  1 

I  A=3 

T  A  A  /OA 

TP2  630 

Art      T  A      T  A  A 

GO  TO  100 

TP2  640 

90 

T  A  A 

I  A=2 

TP2  650 

Y  A  1  1  Al  A  U      T  A  A  A  C   /  i  \ 

IPUNCH=IARGS ( 1 ) 

TP2  660 

A  A     T  A     1  1  A 

bU   1 U  110 

T  A  A      /  "?  A 

IPZ  670 

1  A  A 

100 

T  Al  M  Al  T  T     T  A  D  A  C  /  1  \ 

INUNl l=lAKbo (1 ) 

T  A  A  /OA 

IP2  680 

1  1  A 

110 

1=1 

T  A  A      /  A  A 

TP2  690 

i\A     i  a  A      TT      TA     Al  A  D  A  C 

DO  120   1 1  =  1  A  ,NAKb:> 

T  A  A      T  A  A 

TP2  700 

TAAAC/T\      T  AOTC  /  T  T  \ 

IARGS(I)=IARG5(II) 

T  A  A      T  1  A 

TP2  710 

1  A  A 

120 

IT      TT  1 
1  =  1+1 

T  A  A      "7  A  A 

TP2  720 

Al  A  D  A  C     Al  A  D  A  C      TA  1 

NARG5=NARGS-I A+l 

T  A  A      ^  1  A 

TP2  730 

1  O  A 

130 

LI  1 P=L1 

T  A  A  TilA 

Ir2  740 

A  A      TA        /  1    i  A       ti    ,i  fi       TCA       1   /  A       T   /  A  \             1     -j  r\ 

GO  TO  (140,140,150,160,160),  LIP 

T  A  A      T  C  A 

TP2  750 

T  A  A 

140 

nil  i      nr  a  a  v 

CALL  READX 

T  Pi  A     ~J  /  f\ 

TP2  760 

RL 1  URN 

T  A  A      "7  ~I  A 

TP2  770 

T   C  A 

150 

A  A  1    1       A  1  1  Al  A  LI 

CALL  PUNCH 

T  n  A      T  A  A 

TP2  780 

DTTtlDM 

Rt 1  URN 

T  A  A      T  A  A 

Ir2  790 

1  /  A 

160 

A  A  1    1        f*  C  T 

CALL  SET 

T  r\  A  AAA 

TP2  800 

DCTIIDII 

Rt 1  URN 

T  A  A      A  1  A 

TP2  810 

1  T  A 

170 

TTDD  TADAC/"l\ 

ITPP=IARG5 ( 1 ) 

T  A  A  AAA 

TP2  820 

AA      TA       /  T  A  A      *1  A  A      AAA      A  A  A  \  IA 

GO  TO   (180  , 190 , 200 , 220 ) ,  L2 

T  A  A      O  *>  A 

TP2  830 

ion 
180 

CklHCTt  C  TTDD 

T  A  A      O  Jt  A 

IrZ  840 

DFTItDII 

RETURN 

T  A  A  OCA 

TP2  850 

1  A  A 

190 

DCUiTAIA  TTfin 

RcWIND  ITPP 

T  A  A      Ci  I  A 

TP2  860 

RETURN 

T  A  A      O  "T  A 

Ir2  870 

AAA 

200 

T  D  C  A      T  A  A  A  C  /  A  \ 

IREC=IARG5 (2) 

T  A  A  AAA 

TP2  880 

AA      ATA      T      1  TDCA 

DO  210  I=1,IREC 

T  D  A  AAA 

IP2  890 

READ   (ITPP, 240)  A(l) 

T  A  A  AAA 

IP2  900 

A  A  AIT  T  All  It 

CONTINUE 

T  A  A  ATA 

IPZ  910 

nni  I A  Al 

RETURN 

IP2  920 

AAA 

220 

TDCA  TADAC/A\ 

IRtC=IARGS (2 ) 

IrZ  930 

AA     A  o  a     T     1  TDCA 
DU     230     1=1 , IRtt 

TDO     QA A 

DAAI/CAAAC  TTAA 

BACK5PACE  ITPP 

TDO     Q  C  A 

IrZ  V50 

230 

AftuT  t  til  ir 

CONTINUE 

T  A  A      A  /  A 

TP2  960 

n  r  Ti  i  nil 

RETURN 

T  D  A  ATA 

IrZ  970 

C 

T  A  A      A  O  A 

IrZ  980 

240 

FORMAT  (80A1) 

T  A  A  AAA 

TP2  990 

END 

TP21000 
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SUBROUTINE  THERMO  THE  10 

C         VERSION    5.00          THERMO        5/15/70  THE  20 

C         IT  NOW  CONTAINS  THE  COMMANDS  CTOF ,  FTOC ,  ATOMIC,  MOLWT ,  EINSTEIN,  THE  30 

C         PFTRANSLATIONAL,  PFATOMIC,  AND  PARTFUNCTION  THE  40 

C           THERMODYNAMIC  PACKAGE  WRITTEN  BY  R.  MCCLENON ,  NSRDS-NBS ,  NOV.  69  THE  50 

C  THE  60 

C         THE  VALUES  FOR  L2  ARE  —  THE  70 

C         1  -CTOF  (CENTIGRADE  TO  FAHRENHEIT)  THE  80 

C         2  -  FTOC  (FAHRENHEIT  TO  CENTIGRADE)  THE  90 

C         3  -  ATOMIC  MASS  TABLE  THE  100 

C         4  -  MOLWT  (MOLECULAR  WEIGHT)  THE  110 

C         5  -  EINSTEIN  FUNCTION  THE  120 

C         6  -  PFTRANS  (  PARTITION  FUNCTION  TRANSLATIONAL )  THE  130 

C         7  -  PFATOM  (  P.F.  ATOMIC)  THE  140 

C         8  -  PARTFUNCTION  THE  150 

C         9  -  BOLDISTRIBUTION  (BOLZMAN  DISTRIBUTION)  THE  160 

C  THE  170 

C         WRITTEN  BY  R.  MCCLENON,  NSRDS-NBS,  DEC.  1969  THE  180 

C  THE  190 

C         COMMAND  FORMATS  ARE  AS  FOLLOWS  —  THE  200 

C         CTOF  OF  $$  STORE  IN  COL  ++  THE  210 

C         FTOC  OF  $$  STORE  IN  COL  ++  THE  220 

C         ATOMIC  MASSES  STORE  IN  COL  ++  THE  230 

C         MOLWT  Z=,,  AMOUNT=, ,  Z=, ,  AMOUNT=  STORE  SUM  IN  COL  ++  THE  240 

C         EINSTEIN    TEMP  IN  $$  VIB  FREQ  IN  WAVE  NO  IN  $$  START  STORING  IN  ++THE  250 

C         OR        EINSTEIN    TEMP  IN  $$  FREQ  IN  $$  GAS  CONST  R=, ,  START  IN  ++  THE  260 

C         PFTRANS  TEMP  IN  $$  MOL  WT  M  IN  $$  START  STORING  IN  $$  THE  270 

C         PFATOM    TEMP  IN  $$  MOL  WT  M  IN  $$  WAVE  NO  IN  ++  DEGEN  G  IN  ++  THE  280 

C                  START  STORING  IN  COL  ++  THE  290 

C         PARTFUNC  TEMP  IN  $$  WAVE  NO  IN  ++  G  IN  ++  START  STORING  IN  ++  THE  300 

C         VIBDIST    TEMP  IN  $$  WAVE  NO  IN  ++  G  IN  ++  START  STORING  IN  ++  THE  310 

C  THE  320 

C         SEE  HANDBOOK  101  FOR  DETAILS  ON  STORAGE  BY  ALL  COMMANDS  EXCEPT  THE  330 

C         VIBDIST  (WHICH  IS  NEW)  THE  340 

C         VIBDIST  STORES  THE  PERCENTAGE  OF  MOLECULES  IN  EACH  OF  THE  THE  350 

C         VIBRATIONAL  ENERGY  LEVELS.     IF  THERE  ARE  N  ENERGY  LEVELS  VIBDIST  THE  360 

C         WILL  USE  N  COLUMNS  FOR  STORAGE  THE  370 

C  THE  380 

COMMON  /BLOCKD/  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) ,NRMAX ,NROW,NCOL , NTHE  390 

1ARGS , VWXYZ (8 ) ,NERROR  THE  400 

EQUIVALENCE  (ARGS (1) ,RC (12501) )  THE  410 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , ISRFLG  THE  420 

DIMENSION  ARGS(IOO)  THE  430 

COMMON  /BLOCRC/  NRC , RC  ( 12600 )  THE  440 

DOUBLE  PRECISION  X , EXX , EXDI F , FDEXP , FDLOG , QO ,Q1 ,Q2 ,G ,QQ  THE  450 

COMMON  /SCRAT/  NS ,NS2 , A  (13500)  THE  460 

C             DIMENSION  QQ(NS2)  THE  470 

DIMENSION  QQ(6750)  THE  480 

EQUIVALENCE  (A(1),QQ(1))  THE  490 

DIMENSION  ATWT(103)  THE  500 

DATA  ATWT(l) ,ATWT(2) ,ATWT (3 ) , ATWT (4) ,ATWT(5) , ATWT (6) /l .00800 ,4 . 002THE  510 

160,6.94100,9.01218,10.81000,12.01100/  THE  520 

DATA  ATWT(7) , ATWT (8 ) , ATWT (9 ) , ATWT (10) ,ATWT(11) , ATWT (12 ) /14 . 00670 , 1THE  530 

15.99940,18.99840,20.17900,22.98980,24.30500/  THE  540 

DATA  ATWT (13) ,ATWT(14) ,ATWT(15) ,ATWT(16) , ATWT (17 ) , ATWT (18) /26 . 9815THE  550 

10,28.08600,30.97380,32.06000,35.45300,39.48000/  THE  560 

DATA  ATWT (19) ,ATWT(20) ,ATWT(21) ,ATWT(22) ,ATWT(23) , ATWT (24) /39 . 1020THE  570 

10,40.08000,44.95590,47.90000,50.94140,51.99600/  THE  580 

DATA  ATWT(25) ,ATWT(26) , ATWT (27 ), ATWT (28 ), ATWT (29 ) , ATWT (30 ) /54 . 9380THE  590 
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10,55  .84700 ,58 .93320 ,58 .71000,63 .54600,65 .37000/ 


DATA  ATWT(31 


10  ,72  .59000,74 .92160 ,78 .96000,79 .90400,83 .80000/ 


DATA  ATWT(37 


10,87  .62000,88.90590,91.22000,92.90640,95.94000/ 


DATA  ATWT(43 


10  ,101 .07000,102 .90550 ,106.40000 ,107 .86800,112 .40000/ 


DATA  ATWT(49 
100,118.69000 

DATA  ATWT(55 
150  ,137  .34000 

DATA  ATWT(61 
100,150.40000 

DATA  ATWT(67 
130,167.26000 

DATA  ATWT(73 
190,183.85000 

DATA  ATWT(79 
150,200.59000 

DATA  ATWT(85 
100,222.00000 

DATA  ATWT(91 
190,238.02900 

DATA  ATWT(97 


,ATWT(32) ,ATWT(33) ,ATWT(34) ,ATWT(35) ,ATWT(36) 


,ATWT(38) ,ATWT(39) ,ATWT(40) ,ATWT(41) ,ATWT(42) 


,ATWT(44) ,ATWT(45) ,ATWT(46) ,ATWT(47) ,ATWT(48) 


,ATWT(50) ,ATWT(51) ,ATWT(52) ,ATWT(53) ,ATWT(54) 
121 .75000  ,127  .60000,126.90450,131 .30000/ 
,ATWT(56) ,ATWT(57) ,ATWT(58) ,ATWT(59) ,ATWT(60) 
138  .90550 ,140 . 12000 , 140 . 90770 , 144 . 24000 / 
,ATWT(62) ,ATWT(63) ,ATWT(64) ,ATWT(65) ,ATWT(66) 
151 .96000 ,157 .20000,158.92540,162.50000/ 
,ATWT(68) ,ATWT(69) ,ATWT(70) ,ATWT(71) ,ATWT(72) 
168.93420,173 .04000 ,174.97000 ,178.49000/ 
,ATWT(74) ,ATWT(75) ,ATWT(76) ,ATWT(77) ,ATWT(78) 
186  .20000  ,190 .20000 ,192 .22000 ,195 .09000/ 
,ATWT(80) ,ATWT(81) ,ATWT(82) ,ATWT(83) ,ATWT(84) 
204.37000,207  .20000,208.98060,210.00000/ 
,ATWT(86) ,ATWT(87) ,ATWT(88) ,ATWT(89) ,ATWT(90) 
223.00000,226.02540,227 .02000,232 .03810/ 
,ATWT(92) ,ATWT(93) ,ATWT(94) ,ATWT(95) ,ATWT(96) 
237  .04820,239.00000,243 .00000,247 .00000/ 


THE  600 

/69.7200THE  610 

THE  620 

/85.4678THE  630 

THE  640 

/98.9062THE  650 

THE  660 

/114.820THE  670 

THE  680 

/132.905THE  690 

THE  700 

/147.000THE  710 

THE  720 

/164.930THE  730 

THE  740 

/180.947THE  750 

THE  760 

/196.966THE  770 

THE  780 

/210.000THE  790 

THE  800 

/231.035THE  810 

THE  820 


,ATWT(98) ,ATWT(99) ,ATWT(100) , ATWT (101) , ATWT ( 102 ) /247 .THE  830 


100000,249  .00000,254 .00000,253 .00000 ,255 .00000 ,257 .00000/ 
DATA  ATWT(103)/255.0/ 

GOTO  (10,250,260,380,490,590,640,710,760),  L2 
C         THIS  IS  CTOF 
10  M=l 

20        IF   (NARGS-2 )  1210,30,1210 
30        CALL  ADRESS  (2,12) 

IF   (12)  1220,1230,40 
40        CALL  ADRESS  (1,11) 

IF   (II)  50,1230,50 
50        IF  (NRMAX)  1240,1240,60 
60        IF  (NERROR)  1180,70,1180 
70        IF   (II)  160,1230,80 
80  IE=0 

DO  150  J=l , NRMAX 

II1=I1+J-1 

II2=I2+J-1 

IF  (M-l)  1180,100,90 
90  RC(II2)=(RC(IIl)-32.0)/1.8 

IF   (RC (112) +273 .15)  110,150,150 
100      IF   (RC  ( 1 1 1 )+273 . 15 )  110,140,140 
110      IF  (IE)  130,120,130 
120      CALL  ERROR  (230) 

IE=1 

130      IF   (M-l)  1180,140,150 

140      RC ( 1 12 )  =  (1 . 8*RC (III) )+32  .0 

150  CONTINUE 

GO  TO  1180 
160      IF  (M-l)  1180,180,170 
170  T=(ARGS(l)-32.)/1.8 

IF   (T+273.15)  190,230,230 
180      IF  (ARGS(l)+273 .15)  190,220,220 
190      IF   (IE)  210,200,210 
200      CALL  ERROR  (230) 

IE=1 


THE  840 
THE  850 
THE  860 
THE  870 
THE  880 
THE  890 
THE  900 
THE  910 
THE  920 
THE  930 
THE  940 
THE  950 
THE  960 
THE  970 
THE  980 
THE  990 
THE1000 
THE1010 
THE1020 
THE1030 
THE1040 
THE1050 
THE1060 
THE1070 
THE1080 
THE1090 
THE1100 
THE1110 
THE1120 
THE1130 
THE1140 
THE1150 
THE1160 
THE1170 
THE1180 
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210 

IF   (M-l)  1180,220,230 

THE1190 

220 

T=(l .8*ARGS (1) )+32 .0 

THE1200 

230 

DO  240  J=l, NRMAX 

THE1210 

1 1 2=1 2+J-l 

THE1220 

240 

RC(II2)=T 

THE1230 

GO  TO  1180 

THE1240 

C 

THIS  IS  FTOC 

THE1250 

250 

M=2 

THE1260 

GO  TO  20 

THE1270 

C 

THIS  IS  ATOMIC  WEIGHT 

THE1280 

260 

IF   (NARGS-1)  1210,280,270 

THE1290 

270 

CALL  ERROR  (221) 

THE1300 

280 

CALL  ADRESS  (1,11) 

THE1310 

IF   (11)  1220,1230,290 

THE1320 

290 

IF   (NROW-92)  300,310,310 

THE1330 

300 

CALL  ERROR  (226) 

THE1340 

310 

IF   (NERROR)  1180,320,1180 

THE1350 

320 

IF   (NROW-103)  330,340,340 

THE1360 

330 

L=NROW 

THE1370 

GO  TO  350 

THE1380 

340 

L=103 

THE1390 

350 

00  360  J=1,L 

THE1400 

1 1 1=1 1+J-l 

THE1410 

360 

RC(II1)=ATWT(J) 

THE1420 

IF   (NRMAX-L)  370,1180,1180 

THE1430 

370 

NRMAX=L 

THE1440 

GO  TO  1180 

THE1450 

C 

THIS  IS  MOLWT 

THE1460 

380 

I=NARGS 

THE1470 

CALL  CKIND  (I) 

THE1480 

IF   (1-1)  390,1220,1220 

THE1490 

390 

N=NARGS/2 

THE1500 

IF   (NARGS-2*N )  400,1210,400 

THE1510 

400 

IF   (NRMAX)  1240,1240,410 

THE1520 

410 

CALL  ADRESS  (NARGS  ,  I ) 

THE1530 

IF   (I)  1220,1230,420 

THE1540 

420 

WT=0 . 0 

THE1550 

IF   (N-l)  1210,430,430 

THE1560 

430 

IF   (NERROR)  1180,440,1180 

THE1570 

440 

DO  470  J=2,NARGS,2 

THE1580 

K=IARGS(J-1) 

THE1590 

IF   (K-103)  450,450,1250 

THE1600 

450 

IF   (K)  1250,1250,460 

THE1610 

460 

WT=WT+ATWT(K)*FLOAT(IARGS(J) ) 

THE1620 

470 

CONTINUE 

THE1630 

DO  480  J=l, NRMAX 

THE1640 

II=I+J-1 

THE1650 

480 

RC(II)=WT 

THE1660 

GO  TO  1180 

THE1670 

C 

SPACE  RESERVED  FOR  EINSTEIN,  PFTRANS,  PFATOMIC,  AND  PARTFUNCTION 

THE1680 

C 

THIS  IS  EINSTEIN 

THE1690 

490 

IF  (NARGS-5 )  500,1210,1210 

THE1700 

500 

IF  (NARGS-3)  1210,510,530 

THE1710 

510 

CALL  ADRESS  (3,1) 

THE1720 

IF   (I)  1220,1230,520 

THE1730 

520 

R=l  .0 

THE1740 

II=IARGS(3) 

THE1750 

GO  TO  560 

THE1760 

530 

CALL  ADRESS  (4,1) 

THE1770 

309 


V    I-          /   T    \         Tt    A  A  A        i    a  «i  A        P    1  A 

IF   (I)  1220,1230,540 

THE1780 

540 

▼  r—      /  1/  T  II  A  /  1  v      i\      *i  A  A  A     r*  •■  A     t  A  A  A 

IF   (KIND(3)-l)  1220,550,1220 

THE1790 

550 

R=ARGS (3 ) 

1  1  T™  T  AAA 

THE1800 

1 1=1 ARGS (4) 

T  i  i  r  i  a  i  a 

THE1810 

IF   (R)  1250,1250,560 

i  i  r™~  ^  aaa 

THE1820 

560 

CALL  ADRESS  (2,IFQ) 

THE1830 

T  f™        /  T  1"*  A  v       ^  T  A       "i  A  A  A       r*  A  A 

IF   (IFQ)  570,1230,580 

T  1  ■  r™  Ti    A    A  A 

THE1840 

570 

F=ARGS (2 ) 

t  i  i  r  •■  a  ^  a 

THE1850 

t  r~       /  F"  \       i  a  r/  A      i  a  r*  a      r*  A  A 

IF   (F)  1250,1250,580 

tut i a / a 

THE1860 

580 

TP"                                    TT       ^  \        T  A  A  A       AAA  AAA 

IF   (NCOL-II-7)  1230,800,800 

Tiir~Ti  a^a 

THE1870 

590 

TP"           «  i|    I    r\         f          A     .            Tl    A   Tl     A          y    A  A          x    A  A 

IF  (NARGS-3)  1210,600,1210 

~fT  1  1  t™  Ti    A  A  A 

THE1880 

600 

CALL  ADRESS  (3,1) 

THE1890 

T  f™          /   T    \         T    A  A  A        ^    A  A  A        /    T  A 

IF   (I)  1220,1230,610 

TUT  1  AAA 

THE1900 

610 

1 1  =  1 ARGS (3 ) 

ti  ir  i  a  ■»  a 

THE1910 

a  «  |  g      i  nnr  r  r      /a     t  hit  \ 

CALL  ADRESS  (2 , IWT) 

T  1  1  l~  Ti  AAA 

THE1920 

T  J"         i   T  IIIT  \          y    A  A        1    A  A  A        /    A  A 

IF   (IWT)  620,1230,630 

T  1  1  r"  Ti  AAA 

THE1930 

620 

HIT      A  A      f   /  a  \ 

WT=ARGS (2) 

TI  If*  1    A    A  A 

THE1940 

t  r™      /  isnr  \      ^  a  ^  a     ti  a  f»  a     y  a  a 

IF  (WT)  1250,1250,630 

ti  in  a  f  a 

THE1950 

630 

T   f          /  M  A  A  |           TT         /     v         Ti    A  A  A        AAA  AAA 

IF   (NCOL-II-6)  1230,800,800 

ti  in  Ay  a 

THE1960 

640 

T  f-        /llin^P       r-   »         "1   A  T   A       /PA       1  A  1  A 

IF   (NARGS-5)  1210,650,1210 

ti  in  ATA 

THE1970 

650 

a  a  ■  i       4  nnrr  r      is-  T\ 

CALL  ADRESS  (5,1) 

THE1980 

T                i   T    \         T*    A  A  A        Ti    A  A  A        y    y  A 

IF   (I)  1220,1230,660 

T  1  IT  1  AAA 

THE1990 

660 

TT  T'.PiAP'/r'v 

I I=IARGS (5 ) 

T  1  1  f~  A  A  A  A 

THE2000 

a»ii      i  ftnrpr      /a     t  hit  \ 

CALL  ADRESS   (2, IWT) 

T  1  1  f  A  A  1  A 

THE2010 

T  C       /  T  HIT  \       ZTA      T  A  1  A      /  a  n 

IF    (IWT)  670,1230,680 

THL2020 

670 

hit     i  n/>  r  /  a  \ 

WT=ARGS (2 ) 

T  1  1  P"  A  A  A  A 

THE2030 

T    1™           /  HIT   V           1     A   If"   A          1     a   r   A          /     A  A 

IF   (WT)  1250,1250,680 

T  1  1  f"  A  A   A  A 

THE2040 

680 

a  a  ■  i      »i\r»r"f*f      /a     t  p*  a  \ 

CALL  ADRESS  (3, IFQ) 

T  1  1  f"*  A  A  r~  A 

THE2050 

IT                   /    ?   ^  A    \                 A  A  A          Ti    A  A   A          /    A  A 

IF   (IFQ)  1220,1230,690 

T  1  1  r™  A  a  y  A 

THE2060 

690 

A  A  1     1           *.  f\  Pi  P*  C  C          /    /J         T  A  « 

CALL  ADRESS  (4,IG) 

TI  IT  rt  ft  1  rt 

THE2070 

TP"          /  T  A  \         -|    A  A  A        ■»    A  A  A        ^  A  A 

IF   (IG)  1220,1230,700 

T  1  1  r™  A  A  A  A 

THE2080 

700 

TP*          /HA  A  1           TV         y     v          ti    A  A  A        AAA  AAA 

IF  (NCOL-II-6)  1230,800,800 

T  1  1  r  A  A  A  A 

THE2090 

710 

T  IT™          /  ftl  A  Pi  A  C         A    \          t    A  Tl    A        "Tl  A  A        1    A  Tl  A 

IF   (MARGS-4)  1210,720,1210 

Tiir- AT  AA 

THE2100 

720 

A  A  1    J        1  hnrrf       t  a       T  \ 

CALL  ADRESS  (4,1) 

Tliro  1   1  A 

THE2110 

T  t~       /T\       T  A  A  A      *1  A  *5  A      T  A  A 

IF   (I)  1220,1230,730 

T  U  C  1  1  O 

1 HLZIZO 

730 

TT        T   A  P»  A  P    /  A  \ 

1 1  =  1 ARGS (4 ) 

Tlir"Al  AA 

IHE2130 

a  a  (i   i       a  r\  Pi  P*  P"  P"      /A      t  r~  a  » 

CALL  ADRESS  (2, IFQ) 

T|  |  r  A  1    A  A 

THE2140 

T                   ,    T    ^™  A    \           Ti    A  A  A                A  A   A          ^    A  A 

IF   (IFQ)  1220,1230,740 

T 1  1  f  a  i  r  A 

THE2150 

740 

A  A  1     1           A  A  (A  IT"  P"  P          /A  TAv 

CALL  ADRESS  (3,IG) 

T  1  1  f"  A  1   /  A 

THE2160 

T   ^          /  T  A  \          Tl    AAA        S    A  A  A        T  ^  A 

IF   (IG)  1220,1230,750 

Tliri  1  TA 

THE2170 

750 

I  WT=0 

T  1  1 1-  A  1  AA 

THE2180 

T   *~            ,          A  A.  I            TT          Al           Ti    A  A  A         A  A  A         A  A  A 

IF  (NCOL-II-3)  1230,800,800 

Tlir^l  AA 

THE2190 

760 

T  *~~          i  A  0  A  IA  A  f~         A    \         Ti    A  H    A        "i?  ~J  A              A  Tl  A 

IF   (NARGS-4)  1210,770,1210 

TllfTAAAA 

THE2200 

770 

A    All             A   f\  n  *™  A  y™            ,     o           V  % 

CALL  ADRESS  (4,1) 

THE2210 

IF   (I)  1220,1230,780 

T  1  1  r"  A  A  A  A 

THE2220 

780 

T  HIT  A 

I  WT=0 

I HtZ230 

TT         T    A  ft  A  A    /    A  \ 

1 1  =  1 ARGS (4) 

T  LI  C  A  a  a  a 

THt2240 

A    All             A   A.  n         /■  A            f   A          T   ^  jA  V 

CALL  ADRESS  (2,  IFQ) 

T|ir"AAf»A 

THE2250 

T                   -    V          A    «           V    A  A  A          Ti    A  A  A                A  A 

IF   (IFQ)  1220,1230,790 

X  LI  C  A  A  /  A 

790 

A  A         1           A  A  n  f  A  A          /A  TA\ 

CALL  ADRESS  (3,IG) 

I HL2270 

y  i-        ,  T  A  »        1  A  A  A      "i  A  A  A  AAA 

IF  (IG)  1220,1230,800 

Tur OOOft 

I  HL2 2oU 

800 

A    A    ■      I             A          0\         A  A            ,    w           T          A\  \ 

CALL  ADRESS  (1,ITP) 

T  LI  C  A  A  A  A 

Tnt2290 

T  ^          ,    t  T  a~v  i         A^A        ^AAA  AAA 

IF  (ITP)  810,1230,820 

I HL2300 

810 

T=ARGS(1) 

TUT*  1  1  A 

THE2310 

IF  (T)  1250,1250,820 

T  LI  C  A  *1  A  A 

THE2320 

820 

IE=0 

V  W~          ,  1 1  Ak  AAA  V/  \          ^    A   A  A        1    A   A  A  AAA 

IF  (NRMAX)  1240,1240,830 

1 HtZ340 

830 

t  r*     / 11  r  n  n  An  \     t  d  a  a    a  a  a     t  i  a  a 

IF   (NERR0R)  1180,840,1180 

TUEottn 

840 

IF  (L2-8)  890,850,850 

THE2360 

310 


850 

DO  880  J=NR0W,1,-1 

THE2370 

IIG=IG+J-1 

THE2380 

IF   (RC(IIG))  1260,880,860 

THE2390 

860 

KK=J 

THE2400 

IF   (KK-NS2)  890,890,870 

THE2410 

870 

IF   (L2-8)  890,890,1190 

THE2420 

880 

CONTINUE 

THE2430 

GO  TO  1270 

THE2440 

890 

DO  1170  J=1,NRMAX 

THE2450 

IF   (ITP-1)  910,900,900 

THE2460 

900 

IIT=ITP+J-1 

THE2470 

T=RC(IIT) 

THE2480 

IF   (T)  1150,910,910 

THE2490 

910 

IF   (IWT)  940,920,930 

THE2500 

920 

WT=1.0 

THE2510 

GO  TO  940 

THE2520 

930 

IIW=IWT+J-1 

THE2530 

WT=RC(IIW) 

THE2540 

IF   (WT)  1150,940,940 

THE2550 

940 

IF   (L2-8)  1000,950,950 

THE2560 

950 

Q0=0  . 

THE2570 

Q1=0 . 

THE2580 

Q2=0. 

THE2590 

DO  990  JJ=1,KK 

THE2600 

IIF=IFQ+JJ-1 

THE2610 

IIG=IG+JJ-1 

THE2620 

E=RC(IIF) 

THE2630 

G=RC(IIG) 

THE2640 

IF  (G)  1260,960,960 

THE2650 

960 

IF   (E)  1130,970,970 

THE2660 

970 

X=1.43879D0*DBLE(E)/DBLE(T) 

THE2670 

EXX=FDEXP(-X) 

THE2680 

Q0=Q0+G*EXX 

THE2690 

Q1=Q1+G*X*EXX 

THE2700 

Q2=Q2+G*X*X*EXX 

THE2710 

IF  (L2-8)  990,990,980 

THE2720 

980 

QQ(JJ)=G*EXX 

THE2730 

990 

CONTINUE 

THE2740 

GO  TO  1010 

THE2750 

1000 

Q0=1.0 

THE2760 

Q1=0. 

THE2770 

Q2=0. 

THE2780 

IF  (L2-6)  1020,1010,1010 

THE2790 

1010 

FE=2.5*FL0G(T)+1.5*FL0G(WT)-3 . 66495+SNGL (FDLOG (QO ) ) 

THE2800 

HE=2.5D0+Q1/Q0 

THE2810 

S=FE+HE 

THE2820 

CP=2.5D0+Q2/Q0-(Q1/Q0)*(Q1/Q0) 
HBYT=HE*T 

THE2830 

THE2840 

GO  TO  1050 

THE2850 

1020 

IF  (IFQ-1)  1040,1030,1030 

THE2860 

1030 

IIF=IFQ+J-1 

THE2870 

E=RC(IIF) 

THE2880 

IF  (E)  1130,1040,1040 

THE2890 

1040 

X=1.43379D0*DBLE(E) /DBLE(T) 

THE2900 

EXX=FDEXP(-X) 

THE2910 

EXDIF=1.0D0-EXX 

THE2920 

FE=-FDLOG (EXDIF) *R 

THE2930 

HE=(X*EXX/EXDIF)*R 
CP=R*X*X*EXX/ (EXDIF*EXDIF) 

THE2940 

THE2950 
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b=r  t+tlt 

1 Ht2960 

URVT  UC*T 
tlut  1  =n  l  1 

T  U  C  1  ft  7  ft 

1 Ht2970 

1  A  C  ft 

lObO 

it  Till 

K.=  1  +J  —1 

1 Ht29o0 

t  c    ii  i  o\    i  n  a  n  inon  linn 
lr   (L2— o)   iu  o  u  ,  i  u  7  u  ,  1 1  u  u 

1 Ht2990 

1  ft  L  ft 

1U60 

t c    /i  i  l\    l  Ain   inon  inon 
lr    (Li.—  0)    1 U / U  ,  1 UoU , 1 U o 0 

T  U  C  1  A  ft  ft 

1 Ht3000 

1  ft  7  ft 
10/0 

or  iv  \  c 
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1  Ht30 10 

l\=f\  KUn 

T  U  C  1  A  1  A 

1 Ht3020 

1  ft  Q  ft 

1  U  o  U 

KU  (  l\  )  =  1 

T  U  C  7  ft  1  ft 

1 Mt30i0 

l\=rv      s\  U  If 

TUC 1  ft / ft 

1 ntjOHO 
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TUC  7  ft  C  ft 
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or  / 1/  \  up 
K\j  \  h. )  =nt 
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dp / v  \ _nn 
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I ntj ibO 

TUC  7  1  L.  n 

1  rlt3 160 

op          n i 

TUC  7 1  7ft 

1 Ht31/0 

TUC7 1 QA 
1 ntj lOU 

Pf  /  it  \  ni 

TUC  7 1 Qft 
1  lit  3  170 

cn  xn  ii7n 

bU     1  U    J.  X  1  u 

tuc  7  0 nn 

1  ntj  i.  UU 

1 100 

t  c    /MPfti    tt   \f\i\    iinn   liift  iiift 
1  r    ( NbUL— 1  1  —  M\  )    12U0  ,  1110  ,  1110 
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1 Ht3210 
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TUC  7  O  C  ft 
1  fit  J  C  b  0 

1  I  JU 
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1 Mt3  2  60 

n  i  _n 

TUC  7  9  7  ft 
1  nt  3  c.  1  0 

no  n 

y z=u  . 

T UC  7  9  0  n 

I  C      /  I  C  \      1  ni  n     1  1  yl  ft     1  ft  1  ft 

lr    (it;    1 U 1 0  , 1 140  , 1 0 1 U 

TUC  7  9  Q  n 
1 nt 3 2  7  0 

i  i  An 

pai  i    cpphp  oioi 

LALL    tl\ltUI\  \ct\7) 

THC77ftn 

IC  1 

1  t=l 

TUC  7  7 1 n 
1  nt.33  10 

pn  Tn   i  (ii  n 
bU    ID  1010 

TUC  7  7  O  ft 

1  Mt3320 

1150 

r  t=U  . 

TUC  7  7  7  ft 
1 Mt3330 

rlt=0  . 

TUC  7  7  A  ft 

1  Mt33'*0 

P  D  ft 

Lr=0  . 

TUC  7  7  en 
1  nt.? 3  bU 

c  ft 
b=0  . 

TUC  7  7  An 

URVT  ft 
Hb  Y 1 =0 . 

TUC  7  7  7  n 

1 nt j 3  1  u 

T  r     /  i r i     lftcn    l  l  id  IAEA 

lr    (It)   lObO  ,  1 160  ,  lObO 

TUC  7  7  Q ft 
1  nt  3  30\J 

1  1  L  A 

1160 

A  A  1  1      CDDAD      /  1  *i  O  \ 

LALL  tKKUK  (229) 

TUC  7  7  on 
1 Mt3390 

T  C  1 
1  t  =  l 

TUC  7dnn 

pn  Tn  iftcn 
bU    1  U  lObO 

TUC  7 A  1 n 
1 nt 3 t x u 

117  0 

PAMT  T  Ml  IC 

LUIM  I  1  Nut 

TUC  7 A  7  n 

1 1  o  0 

DCTI IDKI 
Kt 1 UKN 

TMC7A70 

1  nt  3Hj\) 

1  1  A  A 

1190 

pit  1      rnnftn     /  1  Q  \ 

LALL  tKKUK    ( 23  ) 

TUC  "XAA(\ 

\  nt jttu 

pn  Tn  iioft 
bU    IU  lloO 

TUC74i;n 
1 nt 3 n J u 

1  O  ft  ft 

1200 

p  A i  i    rppnp    m  7  i 
UALL   tKKUK    ( 1  /  ) 

1 ntJHDU 

nn  Tn  iioft 
bU    IU   1  loO 

TUC7A7rt 

1 nt / u 

liiA 
1210 

psi  i      rnnftn  /1ft\ 

LALL  tKKUK  (10) 

tuc  7 Aon 
1 nt jtou 

A  A     TA  llOA 

bU   IU  1180 

TUC  7AOft 

1  nt  j*>7U 

1220 

ftfli   l      CDDAD      /  *5  A  \ 

LALL  tKKUK  (20) 

TUC  7  Qrtft 

1 nt; duu 

PA     TA     1  1  Q  A 

bU    1 U  1 180 

tuc  7  c 1 n 

1 ntj jlU 

1  1  O  A 

1230 

A  A  1  1      CDDAD  /11\ 

LALL  tKKUK  (11) 

TUC  7  K  9(1 

1 nt 3 d  t u 

P. A    TA     1  ]  0(1 

bU    1 U    i  i  0  U 

THE3530 

1240 

CALL  ERROR  (9) 

THE3540 
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GO  TO  1180 

THE3550 

1250 

CALL  ERROR 

(3) 

THE3560 

GO  TO  1180 

THE3570 

1260 

CALL  ERROR 

(25) 

THE3580 

GO  TO  1180 

THE3590 

1270 

CALL  ERROR 

(224) 

THE3600 

GO  TO  1180 

THE3610 

END 

THE3620 

SUBROUTINE  TPCTPT  (V,T)  TPC  10 

C         VERSION    5.00         TPCTPT        5/15/70  TPC  20 

IF  (V.LE.O.)  GO  TO  30  TPC  30 

IF   (V-AINT(V))  30,10,30  TPC  40 

10        IF  (V.GT.4.)  GO  TO  20  TPC  50 

T=3 .6948*AINT(1 . /V)-l .6561*AINT (2 . /V ) + . 406*AINT (3 . /V ) +2 . 7764*AINT  (TPC  60 

14. /V)  TPC  70 

RETURN  TPC  80 

20        T=l .959964+2 .37227 12/ V+2 .8224986 /V**2+2 .5558497 /V**3+l .5895341 /V**TPC  90 

14+.73289821/V**5  TPC  100 

C         25        FORMAT  (1X/10X,,*  INFORMATIVE  DIAGNOSTIC  *  V  IMPROPER/)          TPC  110 

C         30        WRITE  ( IPRINT  ,25 )  TPC  120 

30        RETURN  TPC  130 

END  TPC  140 
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SUBROUTINE  TRANSF 

VERSION    5.00         TRANSF  5/15/70 
SUBROUTINE  TRANSF  R.V.  5/2/68 

SUBROUTINE  TO  PROVIDE  TRANSFORMATIONS  B=UAU(T)  AND  C=U(I)AU 
L2=l        TRANSFORMATION  B=UAU(T) 

GENERAL  FORMS  OF  TRANSFORM 

M(XAXT)  A(,)  K,K      U(,)     N ,K 

L2-2        BACK  TRANSFORMATION  C=U(T)ALL 
GENERAL  FORMS  OF  BACKTRANS 

M(XTAX)  A(,)  N,N      U(,)  N,K 


STORE  IN  C(, 
STORE  IN  C( 


TRA 
TRA 
TRA 
TRA 
TRA 
TRA 
TRA 
)  TRA 


10 
20 
30 
40 
50 
60 
70 
80 


COMMON  /SCRAT/  NS , NS2  , A ( 13500 ) 
COMMON  /BLOCRC/  NRC  , RC ( 12600 ) 

COMMON  /BLOCKD /  IARGS(IOO) , KIND (100) ,ARGTAB(100) ,NRMAX ,NROW,NCOL 

1ARGS,VWXYZ(8) , NERROR 

DIMENSION  ARGS(IOO) 

EQUIVALENCE  ( ARGS ( 1 ), RC ( 12501 ) ) 

COMMON  /BLOCKE/  NAME (4 ) , LI , L2 , I SRFLG 

DIMENSION  X(3000) 

DOUBLE  PRECISION  X(SUM 

EQUIVALENCE  (X,A) 
* 

CHECK  TO  SEE  IF  WE  HAVE  CORRECT  NUMBER  OF  ARGUMENTS 

* 

IF(NARGS.NE.IO)  CALL  ERROR  (10) 

CHECK  TO  SEE  IF  ALL  ARGUMENTS  ARE  INTEGERS 

* 

J=NARGS 

CALL  CKIND  (J) 

IF  (J.NE.O)  CALL  ERROR  (3) 

* 

CHECK  TO  SEE  IF  DIMENSIONS  ARE  CORRECT 

* 

GO  TO  (30,40) ,L2 

IF  (I ARGS (3) .NE. I ARGS (4) .OR. I ARGS (3) .NE. I ARGS (8; 
GO  TO  50 

IF  (IARGS(3) .NE.IARGS(4) .OR. I ARGS (3) .NE. I ARGS (7; 
* 

CHECK  TO  SEE  IF  DIMENSIONS  ARE  OUT  OF  RANGE 
COMPUTE  ADDRESSES 


CALL  ERROR  (3) 
CALL  ERROR  (3) 


IF  (NARGS.EQ.10)  GO  TO 
IARGS(12)=IARGS(L2+5) 
IARGS(ll)=IARGS(L2+5) 
GO  TO  70 

IARGS(12)=IARGS(L2+6) 
IARGS(ll)=IARGS(L2+6) 
GO  TO  80 

IARGS(10)=IARGS(NARGS) 

IARGS(9)=IARGS(NARGS-1) 

IARGS(8)=IARGS(NARGS-2) 

IARGS(7)=IARGS(NARGS-3) 

IARGS(6)=IARGS(5) 

IARGS(5)=IARGS(4) 

IARGS(4)=IARGS(3) 

J  =3 

CALL  MTXCHK  (J) 
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TRA  100 
TRA  110 

, )TRA  120 
TRA  140 
TRA  150 
TRA  160 

, NTRA  170 
TRA  180 
TRA  190 
TRA  200 
TRA  210 
TRA  220 
TRA  230 
TRA  240 
TRA  250 
TRA  260 
TRA  270 
TRA  280 
TRA  290 
TRA  300 
TRA  310 
TRA  320 
TRA  330 
TRA  340 
TRA  350 
TRA  360 
TRA  370 
TRA  380 
TRA  440 
TRA  450 
TRA  460 
TRA  470 
TRA  480 
TRA  490 
TRA  500 
TRA  510 
TRA  520 
TRA  530 
TRA  540 
TRA  550 
TRA  560 
TRA  570 
TRA  580 
TRA  590 
TRA  600 
TRA  610 
TRA  620 
TRA  630 
TRA  640 
TRA  650 
TRA  660 
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IF   (J-l)  110,90,100 

TRA  670 

90 

CALL  ERROR  (3) 

TRA  680 

RETURN 

TRA  690 

100 

CALL  ERROR  (17) 

TRA  700 

RETURN 

TRA  710 

C 

TRA  720 

C 

CHECK  FOR  PREVIOUS  ERRORS 

TRA  730 

C 

* 

TRA  740 

110 

IF  (NERROR.NE.O)  RETURN 

TRA  750 

IR0WA=IARGS(3) 

TRA  760 

ISP=1 

TRA  770 

IR0WU=IARGS(11) 

TRA  780 

GO  TO  (120,130) ,  L2 

TRA  790 

120 

IADD1=1 

TRA  800 

IADD2=NR0W 

TRA  810 

GO  TO  140 

TRA  820 

130 

IADD1=NR0W 

TRA  830 

IA0D2=1 

TRA  840 

140 

DO  180  J=1,IR0WU 

TRA  850 

DO  170  I=1,IR0WU 

TRA  860 

IUP=IARGS(5)+(I-1)*IADD1 

TRA  870 

IA=IARGS(1) 

TRA  880 

IUT=IARGS(5)+(J-1)*IADD1 

TRA  890 

ISX=NS2 

TRA  900 

DO  160  L=l, IROWA 

TRA  910 

IU=IUP 

TRA  920 

DO  150  K=1,IR0WA 

TRA  930 

X(ISX)=RC(IU)*RC(IA)*RC(IUT) 

TRA  940 

ISX=ISX-1 

TRA  950 

IU=IU+IADD2 

TRA  960 

IA=IA+1 

TRA  970 

150 

CONTINUE 

TRA  980 

IA=IA+NROW-IROWA 

TRA  990 

IUT=IUT+IADD2 

TRA1000 

160 

CONTINUE 

TRA1010 

CALL  SORTSM  ( IROWA* IROWA , SUM) 

TRA1020 

A(ISP)=SUM 

TRA1030 

ISP=ISP+1 

TRA1040 

170 

CONTINUE 

TRA1050 

180 

CONTINUE 

TRA1060 

C 

* 

TRA1070 

C 

STORE  RESULTS  IN  WORKSHEET 

TRA1080 

C 

* 

TRA1090 

IS=1 

TRA1100 

IC=IARGS(9) 

TRA1110 

DO  200  J=1,IR0WU 

TRA1120 

DO  190  I=1,IR0WU 

TRA1130 

RC(IC)=A(IS) 

TRA1140 

IS=IS+1 

TRA1150 

IC=IC+1 

TRA1160 

190 

CONTINUE 

TRA1170 

IC=IC+NROW-IROWU 

TRA1180 

200 

CONTINUE 

TRA1190 

RETURN 

TRA1200 

END 

TRA1210 
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SUBROUTINE  TWOWAY  (LL)  TWO  10 

C         VERSION  5.0      TWOWAY      5/15/70  TWO  20 

COMMON  /BLOCRC/  NRC , RC ( 12600 )  TWO  30 
COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NTWO  40 

1ARGS , VWXYZ (8 ) ,NERROR  TWO  50 

DIMENSION  ARGS(IOO)  TWO  60 

EQUIVALENCE  ( ARGS ( 1 ), RC ( 12501 ) )  TWO  70 

COMMON  /HEADER  /  NOCARD (80) ,  ITLE (60  , 6 ) , LNCNT , IPRINT ,NPAGE , I  PUNCH  TWO  80 

COMMON  /KFMT/  KFMT(IOO)  TWO  90 

COMMON  /SCRAT/  NS ,NS2 , A (13500 )  TWO  100 

COMMON  /ABCDEF/  L(48)  TWO  110 

DIMENSION  IIRGS(IOO)  TWO  120 

EQUIVALENCE  (KFMT , I IRGS )  TWO  130 

DOUBLE  PRECISION  FDSQRT , DK2 , SUM  TWO  140 

DIMENSION  AST0(120)  TWO  150 
EQUIVALENCE  (ND1 ,KIND  (100) ) ,   (ND2 ,KIND (99) ) ,   (ND3 ,KIND (98) ) ,   (ND4,TW0  160 
1KIND(97)),   (ND5,KIND(96) ) ,   (ND6  ,KIND  (95 ) )  ,   (ND7 ,KIND (94 ) ) ,   (ND8,KITW0  170 
2ND(93)),   (ND9,KIND(92) ) ,   (ND10 ,KIND  (91) ) ,   (ND11  ,KIND (90 ) ) ,   (ND12,KTW0  180 
3IND(89)),   (ND13,KIND(88)) ,   (ND14 ,KIND (87 ) )  ,   (ND16  ,KIND  (86) ) ,   (ND17TW0  190 

4,KIND(85)),   (ND18,KIND(84) ) ,   (ND19 ,KIND (83 ) )  TWO  200 

Q              **************************************************************  yyQ  210 

C         OMNITAB  TWOWAY  ANALYSIS  OF  VARIANCE  SUBROUTINE  TWO  220 

C         WRITTEN  BY  DAVID  HOGBEN ,  SEL,  NBS .        4/17/69    VERSION.  TWO  230 

C  TWO  240 

C         TWOWAY  ANALYSIS  FOR  R  =        C  =        DATA  IN  ++  VECTORS  START  IN  ++  TWO  250 

C                                                                                  (WEIGHTS  IN  COL  ++)  TWO  260 

C         MEASUREMENTS  ARE  STORED  IN  THE  COLUMN  ROW  BY  ROW  TWO  270 

C         LAST  ARGUMENT  USED  ONLY  IF  WEIGHTS  ARE  UNEQUAL  (E.G.  IF  ZERO  WTS  TWO  280 

C         FOR  MISSING  OBSERVATIONS  OR  REJECTED  OUTLIERS)  TWO  290 

C         COEFFICIENTS  ARE  STORED  IN  COL  (X+R+C-l)  TWO  300 

C         RESIDUALS  ARE  STORED  IN  COL  (X+R+C)  TWO  310 

C         STANDARD  DEVIATIONS  OF  PREDICTED  VALUES  ARE  IN  COL  (X+R+C+l)  TWO  320 

C         SUMS  OF  SQUARES  ARE  STORED  IN  COLUMN  (X+R+C+2)  TWO  330 

C         R*C  MUST  =  NRMAX  WHICH  MUST  BE  LESS  THAN  OR  EQUAL  TO  NO.  OF  ROWS  TWO  340 

C          (X+R+C+2)  MUST  BE  LESS  THAN  OR  EQUAL  TO  THE  NUMBER  OF  COLUMNS  TWO  350 

C         R+C+6  MUST  BE  LESS  THAN  OR  EQUAL  TO  NCOL  TWO  360 

C         TUKEY/S  TEST  FOR  NON-ADDITIVITY  IS  NOT  DONE  IF  WTS  ARE  SPECIFIED  TWO  370 

C          IF  ZERO  WTS  ARE  USED  FOR  M.O.  THE  ESTIMATES  GIVEN  ARE  THE  SAME  AS  TWO  380 

C                  THOSE  OBTAINED  FROM  DATA  AUGMENTED  USING  THE  M.O.  FORMULA  TWO  390 

C         SIZE  OF  TABLED  CONSTRAINED  BY  NS  AND  ORTHO  TWO  400 

C         MID-RANGE  SUBTRACTED  BEFORE  DOING  FIT  TWO  410 

C         AUTOMATIC  OUTPUT  USING  READABLE  FORMAT  TWO  420 

C         TABLE  OF  STANDARDIZED  RESIDUALS  IS  GIVEN  ON  PAGE  TWO.  TWO  430 

C         FORMAT  STATEMENT  NUMBERS  ARE  *  TWO  440 

C  TWO  450 

Q  ******************************************************************"[■  yyQ 

C         LINES  10  TO  20  GIVE  CONSTANTS  TWO  470 

IXl(I,J,IN)=IN+(I*(I-l))/2+J  TWO  480 

M1=IARGS(1)  TWO  490 

M2=IARGS(2)  TWO  500 

M3=IARGS(3)  TWO  510 

M4=M1*M2  TWO  520 

M5=M1+M2-1  TWO  530 

M6=M1-1  TWO  540 

M7=M1+1  TWO  550 

M8=M2-1  TWO  560 

M9=M6*M8  TWO  570 

M10=M4-1  TWO  580 

M11=IARGS(4)  TWO  590 
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TP     i  M  A  R  ri  C    FO    C  \    Ml  1  —  I  ARCQ  I  c.  \ 

t  wo  Ann 

1  nu    O  u  u 

WIX  J  =  llrtl\V3  J 

t  wn  A 1  0 

1  nU    O  X  U 

Ml  4  —  1 

TWO  A?n 

Ml  5— M9  1 

(VI 1  J — flfl7—  X 

TWO  a in 

1  nu    O  J  u 

Ml  A  — MA_i_Mft 

TWO  AAn 
i  nu  o  *t  u 

Ml  7— MA  /  5 
Ml  /  =IVIH  /  L 

t  wo  a  «;  n 

M9  0— MQ 

T  WO  AAn 

TF    /Ml    IT  0   OR  M?   IT   ">\    GO  TO  9tt 

1  r     ^  mx  .  I_  1  .  L  .  U  1 \  .  n\C  .LI  .  t  J    UU     1  u  7U 

T  WO  A  7  n 
i  nu  o  /  u 

M?  1  — ?  *  /  Ml  4.M?  \  j.1 

TWO  Afin 

r 

LINES  30  TO  90  GIVE  ERROR  CHECKS 

TWO  AQn 

tf  /Mil  4i  in  9n  in 

t  wn  7  n  n 
I  nu  / uu 

1  n 

X  u 

C  Al  1    ERROR  11(11 

TWO  71  n 
i nu  ( iu 

RETURN 

TWO  7?n 
i nu   1  cm 

?o 

L  U 

TE    i  T  ARGS  i  1  \    T  ARGS  IA.W    fiO  Q0  Qn 

TWO  7in 
i  nu   /  j  u 

10 

te  i mi i  r i  An  An  in 

ir      L  nix .?  — 3y  *rU,*tU,Xv 

TWO  7Art 
i nu    i hu 

AO 

TF  ( IABC^  fni  wrni  i  An  An  sn 

T  wn  7 1;  n 
i  nu  /  j  u 

P  Al  1    ERROR  /111 

V/nLL     r_lM\UB\  IXXJ 

t wn  7 An 

i  nu   /  o  u 

RFTURN 

Twn  77n 

i  nu    i  i  u 

Art 

T  WO  7  fi  n 
i nu    f  ou 

70 

TF    MARG^f^    T  ARGS  f4n    AO  Qfl  QO 

TWO  79n 
i  nu    /  7  u 

fin 

no    1  1 0    T— 1    Ml  % 

t wn  ann 
i nu  ouy 

TF    ( K T  NO ( 7  \  \    QO   100  QO 

t  wn  « i  n 
i nu  oiu 

7  U 

r  Ai  |    FRROR    (  %  \ 

t  wn  ft  7  n 
i nu  ocu 

RETURN 

t  wn  ft  i  n 
i  nu  oj\j 

100 

TF    (lARfi^flM    50  50  110 

Twn  ftAO 
i nu  ohu 

110 

CONTINUE 

t  wn  ft  s  n 

1 nu  ODU 

IF  (NRMAX-IARGS(1)*IARGS(2))  120,130,120 

TWn  RAO 
i nu  oou 

1  20 

CALL  ERROR  (16) 

Twn  B7n 

i nu  of u 

RETURN 

T  WO   H  ft  (1 
i nu  oou 

i  in 

X  J  \J 

IF   (M5+M11+2  LT  NC0L  AND  M21+6  LT 

NROWi  GO  TO  140 

t  wn  ft  q  n 

i nu  O/U 

CALL  ERROR  (17) 

t  wn  q  n  n 

RETURN 

t  wn  q  i  n 
i nu  7iu 

140 

NARGS=M5 

t  wn  o  7  n 

1 nu  7£U 

IF  (M5+7.GT.NC0L)  GO  TO  10 

Twn  9in 

i nu 

DO  150  1=1, M5 

TWO  940 

KIND ( I )=0 

TWO  9^n 
I nu  y DU 

ISO 

IARGS(I)=M11+I-1 

Twn  Q An 

i  nu   7  o  v 

CALL  CHKC0L  (J) 

t  wn  9  7  n 
i  nu  7  /  u 

IF  (J.NE.O)  GO  TO  90 

TWO  9fl0 
i nu  7DU 

IF  (NERR0R.NE.0)  RETURN 

Twn  99n 

1 nu  77U 

p 

LINES  100  TO  150  CONSTRUCT  DESIGN 

MATRIX 

t  no  li  n  ifi  n 

i nu iuuu 

K=IARGS(1)-1 

twoi oi n 

i nu iuiu 

DO  160  U1,M4 

twoi n?n 
i nu iu£u 

M19=K+I 

Twni nin 

1  AO 
xou 

RC(M19)=1.0 

T  WO  1  ft  f  ft 
1  nu  x  u  *♦  u 

DO  180  1=2, Ml 

Twm  nsn 

1 nu iuju 

K1=IARGS(I) 

T  H0 1  ft  k  0 
1 nuxuou 

DO  170  K=1,M6 

Twm  n7n 

1 nu iu/u 

DO  170  J=1,M2 

T  HO  1  ft  ft ft 
1 nuxuou 

K2=K1+M2*(K-1)+J-1 

TWOI 090 
1  nu  x  u  7  u 

RC(K2)=0. 

T  15)01  100 

1  11  v  x  X  w  v 

1  70 
if  u 

IF  (K.EQ.I-1)  RC(K2)=1.0 

TWOI 110 
1  nu  x  x  x  u 

DO  180  J=1,M2 

TWOI 1 70 
1 nu 114U 

K2=K1+M2*(M1-1)+J-1 

TWOI 1  in 
1  nu  x  x  j  u 

1  R0 

RC(K2)=-1.0 

TWO1 1  AO 
1 nu  x  x  hu 

DO  200  I=M7,M5 

TW01 150 

1 nv 11 Jv 

DO  200  K=1,M1 

TWHl 1  AO 

DO  190  J=1,M8 

TW01170 

1  WW  X  1  r  v 

K2=IARGS(I)+M2*(K-1)+J-1 

TW01180 
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409-118  OL  -  71  -  21 


D  P  / 1/  0  \     ft  ft 

KL  (IV  2 )=U . u 

T  Uift  1  1  O  A 

1V0 

tr    i  1    c  p.    T    Ml  \    DP  /       \  _1  ft 
lr     \  J  .  Ly  .  1—  Ml  J    KL(I\£}  =  1.0 

T  lun  1  O  A  A 

1 WU12  00 

if  0    TADPC/T  \  i  MO  *  1 
l\2  = 1 AKtob ( 1 ) +MZ   N  — 1 

t  u/n  1  O  1  A 
1  WU 1 2 1 0 

o  a  a 
200 

D  P  / 1/  o  \       1  ft 
KL (K2 )=-! . 0 

t  urn  1  O  O  A 

1 WU1220 

L 

1  TMPC    7ftft    Tfl    505    PAI  1     MCU/  nDTUin 
LllMtO   JOU    IU   i  co   LALL   NLW  UK  1  HU 

Tu/n  ioift 
1  WU  1 2  3  0 

Kl  A  DP  C    Ml  .  MO  .  A 
INAKljb=Ml+M2+0 

T  ii/n  1  O  A  A 

1 WU1240 

I AOTC  (  1  1  M7 
1 AKbb ( 1 ) =mi 

T  U/n  1  O  C  A 

1 WU1250 

T  AOr C  1  0  \  Mil 
1  AKuj ( L ) =M1 1 

t u/n i  Tin 
1  WU  1 2  o  0 

UU    tlU  i=4,NAKuo 

T  U/n  10  7ft 
1  WU 1 2  /  0 

o  i  n 

£  1  U 

I  ART  C  (  I  \     Ml  1  ,  T  A 
IAKoj  \  I  }  =IVI1 1  +  1  —4 

t  u/n  i  o  o  ft 
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K5=K+M21+7 
00  285  1=1,6 
K5=K5-1 

285  RC(K5)=RC(K5-4) 

LINES  400  TO  430  COMPUTE  TERMS  FOR  ANOVA 

IF  (LL.EQ.7)  GO  TO  350 

IF  (M13.EQ.5)  GO  TO  430 

CALL  ADRESS  (NARGS ,K) 

A(1)=0. 

A(2)=0. 

DO  310  1=1, M6 

M19=K+I 

A(1)=A(1)+RC (M19) 

DO  320  1=1, M8 

K4=M6+I+K 

A(2)=A(2)+RC(K4) 

K4=K+M5 

A(3)=RC(K4) 

A(4)=RC(K4+1)-RC(K) 

A(5)=A(1)/FL0AT(M6) 

A(6)=A(2)/FL0AT(M8) 

A(7)=A(3) /FLOAT (M9) 

A(8)=A(5)/A(7) 

A(9)=A(6)/A(7) 

CALL  PROB  (FLOAT (M6) , FLOAT (M9) ,A(8),A(10)) 

CALL  PROB  ( FLOAT (M8) , FLOAT (M9) ,A(9),A(11)) 

CALL  RFORMT  (A ( 1 ) ,4 , 8 , NW1 , NDEC1 , 20 , A ( 1 ) , A ( 1 ) , 0 , 0 ) 

CALL  RFORMT  (A (5) ,3 ,8 ,NW2 ,NDEC2 ,20,A(1) ,A(1) ,0,0) 

CALL  PAGE  (4) 

WRITE  (IPRINT,1680)  M1,M2 

IF  (M13.EQ.5)  GO  TO  510 

CALL  RFORMT  (A (1 ) , 1 , 8 ,NW1 ,NDEC1 , 0 , A (1 ) , A ( 101 ) , 25-NW1 , 0 ) 

CALL  RFORMT  (A (1 ) , 1 , 8 ,NW2 , NDEC2 , 0 , A (5 ) , A ( 126 ) , 25-NW2 , 0 ) 

LINES  500  TO  550  PRINT  ANOVA  WHEN  ALL  WEIGHTS  EQUAL  ONE 

WRITE  (IPRINT,1690)  M6 , (A ( I ) , 1=101 , 150 ) , A (8 ) , A ( 10 ) 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW1 ,NDEC1 , 0 , A (2 ) , A ( 101 ) , 25-NW1 , 0 ) 

CALL  RFORMT  (A (1 ) , 1 , 8 ,NW2 ,NDEC2 , 0 , A (6 ) , A ( 126 ) , 25-NW2 , 0 ) 

WRITE  (IPRINT,1700)  M8 , (A ( I ) , 1=101 , 150 ) , A (9 ) , A ( 11 ) 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW1 , NDEC1 , 0 , A (3 ) , A (201 ) , 25-NWl ,0 ) 

CALL  RFORMT  (A (1 ) , 1 , 8 , NW2 ,NDEC2 , 0 , A (7 ) , A (226 ) , 25-NW2 , 0 ) 

WRITE  (IPRINT,1710)  M9 , (A ( I ) , 1=201 , 250 ) 

CALL  RFORMT  (A (1 ) , 1 , 8 ,NW1 , NDECl , 0 , A (4 ) , A ( 101 ) , 25-NWl , 0 ) 

WRITE  (IPRINT,1720)  M10 , (A ( I ) , 1=101 , 125 ) 

LINES  600  TO  645  COMPUTE  AND  PRINT  FOR  TUKEY'S  TEST 

CALL  ADRESS  (1,J) 

A(12)=0. 

DO  330  11=1, Ml 

DO  330  12=1, M2 

J1=J+M2*(I1-1)+I2-1 

M19=M1+11+I2 

A(12)=A(12)+AST0(I1+11)*AST0(M19)*RC(J1) 

A(12)=(A(12)*A(12))/((A(1) /FLOAT (Ml ) ) * (A (2 ) /FLOAT (M2) ) ) 

A(13)=A(3)-A(12) 

A(6)=A(13)/FL0AT(M9-1) 

A(16)=A(12)/A(6) 

CALL  PROB  (1. ,FL0AT(M9)-1. ,A(16) ,A(17)) 

A(5)=A(12) 

A(14)=A(3) 

CALL  RFORMT  (A (12 ) ,3 , 8 ,NW1 , NDECl , 20 , A ( 1 ) , A (1 ) , 0 ,0 ) 
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340 
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350 


360 


370 


380 


390 


400 


CALL  RFORMT  (A (5) ,3 ,8 ,NW2 ,NDEC2 ,20 ,A(1) ,A(1) ,0,0) 

CALL  RFORMT  (A (1 ) , 1 , 8 , NW1 ,NDEC1 , 0 , A (12 ) , A (101 ) , 25-NW1 ,0 ) 

CALL  RFORMT  (A (1) , 1 ,8 ,NW2 ,NDEC2 ,0 , A (5) , A (126) , 25-NW2 ,0 ) 

WRITE  (IPRINT,1740)  M14 , (A ( I ) , 1=101 , 150 ) , A ( 16 ) , A  (17 ) 

CALL  RFORMT  (A (1 ) , 1 , 8 ,NW1 ,NDEC1 , 0 , A ( 13 ) , A ( 101 ) , 25-NWl , 0 ) 

CALL  RFORMT  (A (1) ,1,8 ,NW2 ,NDEC2 ,0,A(6) ,A(126) , 25-NW2 ,0 ) 

WRITE  (IPRINT,1750)  M15 , (A ( I ) , 1=101 , 150 ) 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW1 , NDECl , 0 , A ( 14 ) , A ( 101 ) , 25-NWl , 0 ) 

CALL  RFORMT  (A (1 ) , 1 , 8 , NW2 ,NDEC2 , 0 , A (7 ) , A ( 126 ) , 25-NW2 , 0 ) 

WRITE  (IPRINT,1710)  M9 , (A ( I ) , 1=101 , 150 ) 

WRITE  (IPRINT,1760) 

DO  340  1=1,4 

ASTO(I)=A(I) 

LINES  650  TO  690  PRINT  COEFFICIENTS  AND  THEIR  STD .  DEVIATIONS 

CALL  ADRESS  (1,K) 

DO  360  1=1 ,M4 

K5=K-1+I 

RC(K5)=RC(K5)+B 

J=K 

CALL  ADRESS  (NARGS-3 ,K) 

K5=K+M21+7 

DO  370  1=1,6 

K5=K5-1 

RC(K5)=RC(K5-4) 
DO  380  1=1, M21 
K5=K+I 

RC(K5)=AST0(I+11) 

RC(K)=RC(K)+B 

K5=K+M21+1 

A(1000)=RC(K5) 

RC(K5)=RC(K5+3) 

CALL  ADRESS  (2,J1) 

CALL  ADRESS  (NARGSJ2) 

A(1002)=0.0 

SUM=O.ODO 

DO  390  1=1, M4 

A(1002)=A(1002)+RC(J1) 

SUM=SUM+RC(J1)*RC(J)**2 

J=J+1 

J1=J1+1 

J1=J2+M1+M2 

RC(J1)=SUM 

RC(J1+1)=RC(J1+1)+B*FSQRT(A(1002) ) 
RC(J2)=RC(J1+1)**2 
IF  (LL.EQ.6)  GO  TO  400 
RC(K5)=A(1000) 
RETURN 
K5=K+M5+2 
CALL  RFORMT 
CALL  RFORMT 
CALL  RFORMT 
CALL  RFORMT 
WRITE  (IPRINT,1770) 
K5=K+M21+1 
RC(K5)=A(1000) 
DO  410  1=1, Ml 
K5=K+I 
K6=K5+M5+2 

CALL  RFORMT  (A  (1 )  ,  1 , 8 , NW3 ,NDEC3 , 0 , RC (K5 ) , A (101 )  ,  25-NW3  , 0 ) 


(RC(K) ,M5+2,8,NW3,NDEC3,20,A(1) ,A(1) ,0,0) 
(RC(K5) ,M5+3,8,NW4,NDEC4,20,A(1) ,A(1) ,0,0) 
(A(l) ,1,8,NW3,NDEC3,0,RC(K) ,A(101) ,25-NW3,0) 
(A(l) ,1,8,NW4,NDEC4,0,RC(K5) ,A(126) ,25-NW4,0) 
(A(J),J=101,150) 
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CALL  RFORMT   (A (1 ) ,1,8 ,NW4 ,  NDEC4 , 0 ,RC (K6 ) , A (126) , 25-NW4 , 0 ) 
410      WRITE  ( IPRINT  ,  1780)   I , (A ( J ) , J=101 , 150 ) 
WRITE  (IPRINT, 1760) 
DO  420  1-1,112 
K5=K+M1+I 
K6=K5+M5+2 

CALL  RFORMT  (A (1 ) ,1,8 ,NW3 ,NDEC3 , 0 ,RC (K5 ) , A (101 ) , 25-NW3 ,0 ) 
CALL  RFORMT  (A(l) ,1,8,NW4 ,NDEC4 ,0 ,RC (K6) , A (126) , 25-NW4 ,0 ) 
420      WRITE  (IPRINT, 1790)  I , ( A ( J ) , J=101 , 150 ) 
K6=K+M2H4 

CALL  RFORMT  (A (1) ,1,8 ,NW4 ,NDEC4 ,0 ,RC (K6) , A ( 101 ) , 50-NW4 ,0 ) 
WRITE  (IPRINT, 1760) 

WRITE  (IPRINT, 1800)   (A ( J ) , J=101 , 150 ) 
ASTO ( 1 ) =ASTO ( 1 ) +ASTO ( 2 ) +ASTO (3 ) 
AST0(2)=ABS(AST0(4)-AST0(1) ) /ASTO (4) 
IF  (AST0(2) .GT.5.E-7)  CALL  ERROR  (228) 
GO  TO  630 

C         LINES  700  TO  780  GIVE  ANOVA  WHEN  WEIGHTS  ARE  SPECIFIED 
430      CALL  ADRESS  (2, J) 
C         CHECK  ON  WEIGHTS 
K5=J-1 

DO  470  11=1, Ml 
M31=0 

DO  460  12=1, M2 
K5=K5+1 

IF   (RC(K5))  440,450,460 
440      CALL  ERROR  (223) 

RETURN 
450  M31=M31+1 

M9=M9-1 
460  CONTINUE 

IF  (M31.NE.M2)  GO  TO  470 

CALL  ERROR  (224) 

RETURN 
470  CONTINUE 

K5=J-1 

DO  500  11=1, M2 
M31=0 

DO  490  12=1, Ml 
K5=K5+1 

IF  (RC(K5))  480,480,490 
480  M31=M31+1 
490  CONTINUE 

IF  (M3.NE.M1)  GO  TO  500 

CALL  ERROR  (224) 

RETURN 
500  CONTINUE 

M10=M6+M8+M9 

GO  TO  300 
510  J=5 

DO  520  1=1, M8 

IARGS(J)=M11+M6+I 
520  J=J+1 

DO  530  1=1, M6 

IARGS(J)=M11+I 
530  J=J+1 

DO  540  1=1,11 
540  ASTO(I)=A(I) 

CALL  ADRESS  (1,J) 
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(1,J) 

(2,K) 

(NARGS-2,K1) 
(NARGS-1.K2) 


CALL  ADRESS  (2,K) 
DO  550  1=1, M17 

K5=J-1+I 
K6=J+M4-I 
A(20)=RC(K5) 
RC(K5)=RC(K6) 
RC(K6)=A(20) 
K5=K-1+I 
K6=K+M4-I 

A(20)=RC(K5) 

RC(K5)=RC(K6) 
550  RC(K6)=A(20) 

GO  TO  690 
560      CALL  ADRESS 

CALL  ADRESS 

CALL  ADRESS 

CALL  ADRESS 

DO  570  1=1, M17 

K5=J-1+I 
K6=J+M4-I 
A(20)=RC(K5) 
RC(K5)=RC(K6) 
RC(K6)=A(20) 
K5=K2-1+I 
K6=K2+M4-1 
A(20)=RC(K5) 
RC(K5)=RC(K6) 
RC(K6)=A(20) 
K5=K1-1+I 
K6=K1+M4-I 
A(20)=RC(K5) 
RC(K5)=RC(K6) 
RC(K6)=A(20) 
K5=K-1+I 
K6=K+M4-I 
A(20)=RC(K5) 
RC(K5)=RC(K6) 
570  RC(K6)=A(20) 
A(18)=0. 

CALL  ADRESS  (NARGS ,K) 

DO  580  1=1, M8 

K5=I+K 
580  A(18)=A(18)+RC(K5) 

A(17)=0. 

DO  590  1=1 ,M6 

K5=M2+I+K-1 
590  A(17)=A(17)+RC(K5) 

Jl=M21-2 

K5=201 

K6=K+1 

DO  600  1=1, Jl 
A(K5)=RC(K6) 
K5=K5+1 
600  K6=K6+1 
K5=K+1 
K6=201+M8 
Jl=K+M16+4 
J2=204+M16+M8 
DO  610  1=1, M6 
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TW03980 

TW03990 

TW04000 

TW04010 

TW04020 

TW04030 

TW04040 

TW04050 

TW04060 

TW04070 

TW04080 

TW04090 

TW04100 

TW04110 

TW04120 

TW04130 


322 


610 


620 


630 


640 


RC(K5)=A(K6) 

TW04140 

RC(J1)=A(J2) 

TW04150 

K5=K5+1 

TW04160 

K6=K6+1 

TW04170 

J1=J1+1 

TW04180 

J2=J2+1 

TW04190 

Jl=K+Ml6+M8+3 

TW04200 

J2=204+M16 

TW04210 

DO  620  1=1 (M8 

TW04220 

RC(K5)=A(I+200) 

TW04230 

RC(J1)=A(J2) 

TW04240 

K5=K5+1 

TW04250 

J1=J1+1 

TW04260 

J2=J2+1 

TW04270 

A(19)=A(17) /FLOAT (M6) 

TW04280 

A(20)=A(18) /FL0AT(M8) 

TW04290 

A(21)=A(19) /AST0(7) 

TW04300 

CALL  PROB   (FLOAT (M6) , FLOAT (M9) ,A(21) ,A(22)) 

TW04310 

CALL  RFORMT   (A ( 1 ) , 1 , 8 , NW1 , NDECl , 0 , A ( 17 ) , A ( 101 ) , 25-NW1 , 0 ) 

TW04320 

CALL  RFORMT   ( A ( 1 ) , 1 , 8 ,NW2 , NDEC2 , 0 , A ( 19 ) , A ( 126 ) , 25-NW2 , 0 ) 

TW04330 

WRITE  (IPRINT  .  1690)  M6 , (A ( I ) , 1=101 , 150 ) , A ( 21 ) , A (22 ) 

TW04340 

CALL  RFORMT  ( A ( 1 ) , 1 , 8 , NW1 , NDECl , 0 , A ( 18 ) , A ( 101 ) , 25-NW1 , 0 ) 

TW04350 

CALL  RFORMT   ( A ( 1 ) , 1 , 8 , NW2 , NDEC2 , 0 , A (20 ) , A (126 ) , 25-NW2 , 0 ) 

TW04360 

WRITE  (IPRINT, 1700)  M8 , (A ( I ) , 1=101 , 150 ) 

TW04370 

CALL  RFORMT  (A (1 ) , 1 , 8 , NW1 , NDECl , 0 , ASTO (3 ) , A ( 101 ) , 25 

-NW1,0) 

TW04380 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW2 ,NDEC2 , 0 , ASTO (7 ) , A ( 126 ) , 25 

-NW2,0) 

TW04390 

WRITE  (IPRINT, 1710)  M9 , (A ( I ) , 1=101 , 150 ) 

TW04400 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW1 (NDEC1 , 0 , ASTO (4 ) , A ( 101 ) , 25 

-NW1,0) 

TW04410 

WRITE  (IPRINT, 1720)  M10 , (A ( I ) , 1=101 , 125 ) 

TW04420 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW1 , NDECl , 0 , ASTO ( 1 ) , A ( 101 ) , 25 

-NW1 ,0) 

TW04430 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW2 ,NDEC2 , 0 , ASTO (5 ) , A ( 126 ) , 25 

-NW2,0) 

TW04440 

WRITE  (IPRINT,1690)  M6 , (A ( I ) , 1=101 , 150 ) 

TW04450 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW1 , NDECl , 0 , ASTO (2 ) , A ( 101 ) , 25 

-NW1,0) 

TW04460 

CALL  RFORMT  (A (1 ) , 1 , 8 ,NW2 ,NDEC2 , 0 , ASTO (6 ) , A ( 126 ) , 25 

-NW2,0) 

TW04470 

WRITE  (IPRINT, 1700)  M8 , (A ( I ) , 1=101 , 150 ) , ASTO (9 ) , ASTO ( 11 ) 

TW04480 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW1 , NDECl , 0 , ASTO (3 ) , A ( 101 ) , 25 

-NW1 ,0) 

TW04490 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW2 , NDEC2 , 0 , ASTO (7 ) , A ( 126 ) , 25 

-NW2,0) 

TW04500 

WRITE  (IPRINT, 1710)  M9 , (A ( I ) , 1=101 , 150 ) 

TW04510 

CALL  RFORMT  (A ( 1 ) , 1 , 8 , NW1 , NDECl , 0 , ASTO (4 ) , A ( 101 ) , 25 

-NW1,0) 

TW04520 

WRITE  (IPRINT, 1720)  M10 , (A ( I ) , 1=101 , 125 ) 

TW04530 

M31=M5+M9 

TW04540 

M32=M4-M31 

TW04550 

WRITE  (IPRINT, 1730)  M31,M32,M12 

TW04560 

CALL  ADRESS  (NARGS-3 ,K) 

TW04570 

K5=K+M6+M2+M2 

TW04580 

K6=K+M1+M2 

TW04590 

K3=M1+M1+M2+12 

TW04600 

AST0(K3)=RC(K5) 

TW04610 

AST0(M21+11)=RC(K6) 

TW04620 

GO  TO  350 

TW04630 

CALL  PAGE  (4) 

TW04640 

WRITE  (IPRINT, 1810)  M1,M2 

TW04650 

M31=MIN0(15,M2) 

TW04660 

DO  640  I=1,M31 

TW04670 

KIND (I )=I 

TW04680 

WRITE  (IPRINT, 1820)   (KIND ( I ) , 1=1 , M31 ) 

TW04690 

WRITE  (IPRINT, 1830) 

TW04700 

CALL  ADRESS  (NARGS-2,J) 

TW04710 

CALL  ADRESS  (NARGS-1,K3) 

TW04720 
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TP    /Mil   FO    s  \    KTMn/^—  ft 

tc    /Mil    Pn    c  \    PA|  1  AftDPCC 

( L  ,  W) L  ) 

T  U/fl  A  7  Aft 

1  VlU'J  /  4U 

nn    A7ft    T— 1  MA 
U  U    0  <  U    1  =  1, KIH 

Tl|lfti7  eft 
1 BUt / DU 

TP  /Mil  Fn  «;  ^  on  to.  Asn 

1 r     (  ml  j  . Cy . _> )    uu    1 U  OjU 

TU/0A7  Aft 
1  HUH / 0  U 

ami     DO  |  |  \  /  CCnOT  /  DP  /  K  A  \  *  * 

A  \  i )  =Ku  i  J  )  I  r       I  ( ku ( no  ) 

?  or t  v i \ *  *  ? \ 

TUI0A7  7  ft 
I  nut /  / U 

rn  Trt  AAft 

uu  i u  oou 

T  U/O  A  7  Q  ft 
1 WUH / OU 

a  k  n 

0  DU 

tf   ioriu,x')\  ct  ft  n\  a/t\_ 
1  r    \  Ku  ( mj  L)  .ul  .  U  .  U  )    A  1 1  ;  = 

Or  1  l  \  /FCnDT^/DP/I^A\**9  \  IDC  t  WiO  \ 

or  /  k  ~i  \  *  *  9TU/OA7 on 

— KL>  IIS  J  )  £lnUH/7U 

i  \ 
■«■ ) 

TUIOAfiftft 
1 nUHOUU 

T  F    IOC  I  Ml  5  1    IF    ft    ft\    A  /  T  \  — 
Ir     I  K  w  Nlj  c  )  .  L  C  .  U  .  U  J    A  v  1  J  = 

ft  ft 

u  .  u 

TWO AQ 1  ft 

i nuHoiu 

Ml 5— Ml 5x1 
Wlj  C—mjC+l 

TUJOAQon 

oou 

J=J  +1 

t  \un  a  q  i  f\ 
1  WU'to 

a  7  ft 
0  /  u 

k  7.—U  1^1 
IV  J=IV.}  +  1 

T  U/n  A  Q  A  ft 

nO    ARft    T— 1  Ml 
UU    OOU    1  =  1  ,  Nil 

t  u/n  A  Q  C  ft 
1 WU40DU 

WRTTF    /TPRTNT  17A(11 
nftllC  llrl\lNI,l/OU/ 

T  U/n  A  O  A  ft 
1 WUtoOU 

Ml  1  —  M9*  11     "\  \ 

mj  i — mc    ^  i  — ±  j 

T  u/n  A  O  7  ft 
i nuto / u 

It  A  — Ml  1  ]  MO 

t  u/n  jtoon 

KB=M31+1 

t  u/n  yioon 
1 WU407U 

Ann 
oou 

WRITE  (IPRINT,1840)  I , (A (K) ,K=KB , KA) 

T  U/n  A  O  ft  ft 
1 WU47UU 

RETURN 

T  U/n  A  O  1  ft 

r 
\j 

THIS  IS  NEW  ORTHO  -  SFIT 

PORTION 

T  U/n  A  Q  9  ft 

AQft 

0  7ll 

NMUI=1 

T  U/n  A  Q  1  ft 

1 nUt7 JU 

CALL  ADRESS  (1,1 IRGS  ( 1 ) ) 

t  u/n  A  O  A  ft 

CALL  ADRESS  (2,1 IRGS  (2  ) ) 

t  u/n  A  O  C  ft 

NST=1 

T  U/n  A  Q  A  ft 
1 BU470U 

NEND=NARGS 

TU/nA07ft 
1  HUH 7 / U 

DO  700  1=4  NEND 

K#  W        ■    WW        A  ~^  ~    f  1  •  1_  1  ■  w 

T  U/n  A  Q  B  ft 

CALL  ADRESS  (I  I  IRGS  (In 

t  u/n  A  O  O  ft 

i  n  n 

CONTINUE 

t  u/n  q  ft  n  n 

M=IARGS (3 ) 

t  u/n  c  n  i  n 
i nusuiu 

N=NRMAX 

T  u/n ft  7  n 

FN-N 

t  u/n  c;  ft  •»  n 
i  nu  3  u  j  u 

CM  ft  ft 

JU — w . U 

T  U/n  CftAft 
1 WuDUtU 

1  22— I IRGS (2 ) 

TU/nQftRft 
1 WU3U3U 

L22A-L22 

T  WO  <\  ft  A  ft 
1 WUDUOU 

DO  730   T— 1  N 

TW0<;n7n 

1  iTUDU  /  U 

TF    /RPM??A\\    71ft    71ft  79ft 
ir    ^i\V/  \  L£lh  j  )    /  iu  ,  I  j  u  ,  /  lu 

T  WO  <v  ft  fl  ft 
1 WUDUOU 

7i  n 
/  iu 

r  Al  1    frror    r  o  c  \ 

T  WO  C  ft  Q  ft 
1 WUDU7U 

RPTIIRKI 

T  WO  5  1  ft  ft 
1 BUj 1UU 

7  0  0 
/  C\J 

c  1 1  ci  l  ,  n  n 

JU — jutl . U 

T  wo  ciin 

1  BUD  1 1U 

7  in 

1  ??A— 1  ?9Aj.1 

L££n — U ^  t  n  +  1 

T  WO  5  1  7  ft 
I BUj 1 C U 

FM=M 

t  wo  <;  i  n 

IF   (SU-FM)  740,750,760 

T  WO  C 1  Aft 
1 BUj 1HU 

7  A  ft 

CALL  ERROR  (24) 

T  wo  ci cn 

1 BU313U 

RETURN 

T  WO  C 1  Aft 

i nu  jiou 

/  jU 

DEN0M=1.0 

T  WO  5 1  7  n 

1 BU jl/U 

GO  TO  770 

TWOS l ftft 

1  If  W  JIOU 

7  a  n 

/  OU 

DENOM=FSQRT (SU-FM) 

T  WO  S  1  Q  ft 
1 BUJlTV 

1  IV 

NPM=N+M 

T  WO  5  9  ft  ft 
1 BUjtUU 

M31=M-1 

T  wo  coin 
i nu Di iu 

M32=M+1 

TWOS 9  9  ft 

i nu dc cm 

N1=N-1 

1  TIU  Jt  JU 

N2=N+1 

T  WO  c.  9  A  ft 
1 nUPtHU 

MDl=(M*(M32))/2 

T  WO  c;  o  c  n 
1 BUjljU 

ND1=M32*NPM 

T  WO  C.  9  A  ft 
1 BUjlDU 

ND2=M*NPM 

T  WO  S  9  7  ft 
1 BUj C 1 U 

MD3=ND2+N 

TWO  5.90.(1 
1 BUjlOU 

ND3-ND1 

i nu  jt7u 

ND4=ND3+NPM 

T  WO     ft  n 
i nu  jjuu 

ND5=ND4+NPM 

TW05310 
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780 
790 


800 


810 


820 
830 


840 
850 


ND6=ND5+M32 

TW05320 

ND66=MD1+M 

TW05330 

N07=N06+ND66 

TW05340 

ND8=ND7+ND66 

TW05350 

ND9=ND8+M32 

TW05360 

N010=ND9+M 

TW05370 

ND11=ND10+M 

TW05380 

ND12=N011+M 

TW05390 

ND13=ND12+MD1 

TW05400 

ND14=ND13+M32 

TW05410 

ND16=ND14+M 

TW05420 

ND17=ND16+M 

TW05430 

ND18=ND17+M 

TW05440 

ND19=ND18+NPM 

TW05450 

ND20=ND19+N 

TW05460 

IF  (ND20.GT.NS)  CALL  ERROR  (23) 

TW05470 

IF  (NERROR.NE.O)  RETURN 

TW05480 

NRBAR=1 

TW05490 

1=4 

TW05500 

MXARGS=M+4 

TW05510 

L44=MXARGS-1 

TW05520 

J=l 

TW05530 

DO  790  11=1, L44 

TW05540 

K1=J 

TW05550 

L33=IIRGS(I1) 

TW05560 

K2=K1 

TW05570 

DO  780  12=1, N 

TW05580 

A(K2)=RC(L33) 

TW05590 

K2=K2+1 

TW05600 

L33=L33+1 

TW05610 

J=J+NPM 

TW05620 

K1=N2 

TW05630 

DO  810  K=1,M 

TW05640 

K2=K1 

TW05650 

DO  800  1=1, M 

TW05660 

A(K2)=0. 

TW05670 

K2=K2+1 

TW05680 

K2=K1+K-1 

TW05690 

K1=K1+NPM 

TW05700 

A(K2)=1.0 

TW05710 

NBEI=1 

TW05720 

NRHI=1 

TW05730 

I18=1+ND13 

TW05740 

NGAI=2 

TW05750 

NS 1 1=2 

TW05760 

NDEI=1 

TW05770 

NNUI=1 

TW05780 

LZ1=1 

TW05790 

LZ2=1 

TW05800 

K=l 

TW05810 

NTHI=1 

TW05820 

NALI=1 

TW05830 

N0MI=1 

TW05840 

NJ=ND3+N+1 

TW05850 

DO  840  J=1,M 

TW05860 

A(NJ)=0. 

TW05870 

NJ=NJ+1 

TW05880 

KD1=(K-1)*NPM 

TW05890 

I1=ND3+1 

TW05900 
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1  WU  5  9  3  0 
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1 WUb94U 
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T  u/n  coca 
1 WUd9dO 

T 1  Till 
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T  UJA  C  A  L  A 

1 WU5960 

BbU 

To     T  0  i  1 
1 £=1 Z+l 

T UJA.  coin 

1 WUS9 70 

rn  to    /o7n  onn\  unMT 

uu    IU     10/U,7UU),  NUWI1 

T  UJA  coon 

1 WUb9oO 

o  7  n 

T  A  1  — 1 
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T  UJA  C  O  O  A 

1 W0S99U 

T  A  0— Kin  K  i  1 
1  A£=liiUD  +  l 
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1 WU6010 
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1 4=1 Al 

T  UJA  znin 

1 WU6020 

jUI«=U  .  U 

T  UJA  L  A  0  A 

1 WU6030 
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j  c=nv j+i 

T  UJA  £  A  /I  A 

1 WU6040 

nn  flan   i— l  mpu 
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1 WUoUdO 
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OUIVt=oUIVl+A  ( J  A  )    A  (_  1  £.  ) 
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1 WU6060 

T  9     T  9  i  1 
1 £=1 £+1 

T  UJA  Z  A  7  A 

1 WU6070 

sou 

1  9—  19,1 
J  £  =  J A  +  l 

T  UJA  L  A  O  A 
1 WU60B0 

A  (,  1  A£  J  =oUIVI 

T  UJA  £  A  O  A 

1 WU6090 

1  A  1  =  1  Al+Nr  nfl 
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1 WU610U 

ft  0)  A 
0  7  0 
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1 WU6 1 10 
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1 WU019U 

nK_rncnPT  ^  nK  9  \ 
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1 WUoZ 10 

T  1  O    T  1  Q  i  1 

1 lo=l lo  +  l 

T  UJA  L  O  O  A 

1  nUo/VO 

KI      / 1/    1  \ *  UDM .  1 
M=        1  )    IMr  M+l 

t  uin  £  0 1  A 
1 WUoZ JU 

nn  09n  t   i  udu 
UU   7/U    1=1, NrM 

T  u/n  &  9  A  n 

A  (Kit —A  /KI  \  /  nK 
A  |M  J  =A  (MJ  /  U l\ 

1  nU  0  c  j  U 

Q*)ft 

Ki  Kl.l 

M=M+1 

T  U/n  A  9  £  A 

NUM1=1 

t  u/n  a  9  7  n 

c a  t  a  oca 
bU    1 U  ojU 

T  Uin  L  9  Q  A 
1 WUoZoO 

Qlrt 
57  i  0 

c  A  t  A    /  a  a  f\    i  nun  ^      unr  T 
bU    IU    (940,1000),  NUti 

T  U/n  £  9  Q  n 

1 WU0Z7U 

Ail  A 

94  0 

171  171 

LZ.1=— La.1 

T  u/n  a  t  n  n 

T  r      1171V     AAA     OCA  OCA 

lr    (La.1)   990  ,9b0  ,  9b0 

t  uin  A  1 1  A 
1  WU  0  i  1  u 

OCA 

?  b  0 

1/  T.      1/  1 

K1=K-1 

t  uin  A  t  9  A 
1 WUOJ a0 

IKU 1 H=NUd+1 

t  u/n  Attn 

DO  960   1=1 , Kl 

t  u/n  At  An 
1 wuo j4U 

A  /  T  Dl  ITU  \        n  (  1  DIITU  \ 

A  (  1  KU 1 H ) =— A (  I KU 1 n ) 

T  u/n  a  t  c.  n 
1 nu  oiDU 

A  Z  A 

960 

TDIITU  TDIITU.l 

IKU 1 H=l KU 1 n+1 

TU/nAt  Art 

IKU1  H=K+Nl)5 

t  uin  a  1 7  n 
1  WU  0  3  1  U 

A  /  T  Dl  ITU  \      1  A 

A  ( 1  KU 1 n )  =  1 . 0 

T  u/n  a  t  q  n 
1 WUOjoU 

J  2=ND4+1 

t  u/n  a  1 0  n 

A      AAA       T       1  linii 

DO  980  1=1 , NPM 

t  u/n  a  a  n  n 
1 WU04UU 

C  1  1  ft  i     A  A 

t  wn  a  4 1  n 
1 nuot 1 u 

n  i  t 

j  i=i 

t  uin  a  a  9  n 
1 WU04  A u 

J3=ND5+1 

t  u/n  a  a  t  n 

1 WU04JU 

Ifti  A      A      A       II      1  1/ 

DO  970  J=l , K 

t  u/n  a  a  a  n 

1 WU044U 

CIIIJ    CIIIJ.A  /  M  \  *  A  /   D  -5  \ 

SUM=5UM+A ( J 1 ) *A ( J3 ) 

TwnAARn 

In      I  i  .  ai  o  II 

J 1=J 1+NrM 

t  u/n  aa  ah 

1 WU040U 

ATA 

970 

to      to  ll 

J3=J3+1 

t  u/n  a  a  7  n 

1 WU04 / U 

A  1   1  1  \      C  1  1  ft! 

A  ( J2 )=5UM 

t  u/n  a  a  a  n 

980 

J2=J2+1 

TW06490 
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60  TO  1090 

TW06500 

990 

ISAL=I 18+M32 

TW06510 

IRUTH=ND5+K 

TW06520 

A (ISAL)=FSQRT (A(IRUTH) ) 

TW06530 

GO  TO  950 

TW06540 

1000 

LZ2=-LZ2 

TW06550 

IF   (LZ2 )  1010,950,950 

TW06560 

1010 

DO  1020  1=1, M 

TW06570 

IND5=ND5+I 

TW06580 

IND9=ND9+I 

TW06590 

IND8=ND8+I 

TW06600 

A(IND8)=A(IND5) 

TW06610 

1020 

A(IND9)=A(IND5)*A(IND5) 

TW06620 

A(IND8+1)=A(IND5+1) 
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J=J+1 
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J1=J1+I+1 
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NGAI=1 
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GO  TO  1250 
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TW08220 

GOTO  (1570,1560,1550,1540,1530,1500),  IMS 
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1 WU8830 

w  |—        ,  a  ^  ll     a      av      tin  A  ifli  \       i    /■TA       TTAAA   /  11V/  A  AAA      O  \       AIDA  Ul  1 

IF  (2*M+2 .GT .NR0W)  LSTA=I IRGS (MXARGS+3 )+NR0W-l 

T  UlA  AAiin 

TW08840 

IND8=ND8 

TW08850 
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DO  1640  I=LST,LSTA 

IND8=IND8+1 
1640  RC(I)=A(IND8) 
1650  LST0R=IIRGS(MXARGS+2) 

IPIC=1 

IND2=ND2+1 

DO  1660  1=1, N 

RC(LST0R)=A(IND2) 

IND2=IND2+1 
1660  LST0R=LST0R+1 

IF   (IARGS(5)-IARGS(4)-1)  1670,270,560 
1670  RETURN 
C 
C 

1680    FORMAT  (//,31X,34H  ANALYSIS  OF  VARIANCE  FOR  TWO-WAY  ,I2,3H 

1H  TABLE, //,4X,7H  SOURCE , 13X , 5H  D . F . , 10X , 14HSUM  OF  SQUARES, 1 

2EAN  SQUARES, 10X,17HF  RATIO      F  PROB./) 
1690    FORMAT  (4X,20H  BETWEEN  ROWS  , 14 , 50A1 , 6X , 0PF11 . 3  , F9  . 3 ) 

1700     FORMAT   (4X,20H  BETWEEN  COLS  , 14 , 50A1 , 6X , 0PF11 . 3  , F9  . 3 ) 

1710     FORMAT  (4X,20H  RESIDUALS  ,I4,50A1) 
1720    FORMAT  (4X,20H  TOTAL  ,I4,25A1//) 
1730    FORMAT  (9X,40HA  WEIGHTED  LEAST  SQUARES  ANALYSIS  USING  ,14,2 

1ZER0  WEIGHTS  AND  ,I4,24H  ZERO  WEIGHTS  IN  COLUMN  ,14/) 
1740    FORMAT  (39X ,31HTUKEY' S  TEST  FOR  NON-ADDITIVITY / / ,4X , 20H  NON 

1VITY  ,I4,50A1,6X,0PF11.3,F9.3) 
1750     FORMAT  (4X,20H  BALANCE  ,I4,50A1) 
1760    FORMAT  (IX) 

1770    FORMAT  ( / /5X , 11HC0EFFICIENT , 14X ,8HESTIMATE , 17X ,9HSTD .  DEV./ 

1GRAND  MEAN , 50A1 / ) 
1780    FORMAT  (5X,7HR0W  ,I3,50A1) 
1790     FORMAT   (5X,7HC0LUMN  ,I3,50A1) 
1800    FORMAT  (5X , 10HRESIDUAL  ,50A1) 

1810    FORMAT  (//10X,I2,3H  X  ,I2,86H  TABLE  OF  RESIDUALS,  STANDARDI 

1DIVIDING  EACH  RESIDUAL  BY  ITS  STANDARD  DEVIATION.) 
1820    FORMAT  (/,8H    COLUMN , 15 (3X , 14 , IX) ) 
1830    FORMAT  (8H        ROW  ) 
1840    FORMAT  (2X , 14 , 2X , 15 (2X  ,  F6  .  2 ) ) 
END 
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SUBROUTINE  VARCON  (NAME)  VAR  10 

C         VERSION    5.00         VARCON         5/15/70  VAR  20 

COMMON  /BLOCKA/  MODE , M.KARD (83 ) ,KARG , ARG , ARG2 , NEWCD (80 ) , KRDEND        VAR  30 

DIMENSION  NAME(2) ,  N(14)  VAR  40 

DATA  N(l) ,N(2) ,N(3) ,N(4) ,N(5) ,N(6) ,N(7) ,N(8)  ,N(9) ,N (10) ,N (11) ,N (12VAR  50 

1)  ,N  (13 )  ,N (14)  / 10705, 2604, 16038 ,16767 ,17496, 18225, 18954 ,1377 ,15001, VAR  60 

25*0/  VAR  70 

C  VAR  80 

C           LOOKUP  NAME  IN  VARIABLE-NAME  TABLE  VAR  90 

C  VAR  100 

C              NAMES  IN  TABLE  VAR  110 

C  VAR  120 

C                       NRMAX,COLTOP,V,W,X,Y,Z  VAR  130 

C  VAR  140 

DO  10  1=1,7  VAR  150 

IF  (NAME (1 ) .EQ .N ( I ) .AND .NAME (2 ) . EQ .N ( 1+7 ) )  GO  TO  20                          VAR  160 

10        CONTINUE  VAR  170 

1=0  VAR  180 

20        ARG=I  VAR  190 

RETURN  VAR  200 

END  VAR  210 


SUBROUTINE  VECTOR  (A, J)  VEC  10 

C         VERSION    5.00         VECTOR         5/15/70  VEC  20 

COMMON  /BLOCRC/  NRC ,RC ( 12600 )  VEC  30 
COMMON  /BLOCKD /  IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NVEC  40 

1ARGS , VWXYZ (8 ) ,NERROR  VEC  50 

DIMENSION  ARGS(IOO)  VEC  60 

EQUIVALENCE  (ARGS ( 1 ), RC  (12501 ) )  VEC  70 

C  VEC  80 

C              VECTORIZE  A  IN  TO  COLUMN  STARTING  AT  J  VEC  90 

C  VEC  100 

IF  (NRMAX.EQ.O)  GO  TO  20  VEC  110 

K=J+NRMAX-1  VEC  120 

DO  10  I=J,K  VEC  130 

10        RC(I)=A  VEC  140 

20        RETURN  VEC  150 

END  VEC  160 
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SUBROUTINE    XECUTE  XEC  10 

C         VERSION    5.00        XECUTE        5/15/70  XEC  20 

COMMON /BLOCKE/  NAME (4) , LI ,L2 , ISRFLG  XEC  30 

COMMON /BLOCKX/  INDEX (6,8) , LEVEL  XEC  40 

C  *****  XEC  50 

C         Ll=l-10    FOR  COMMANDS  CONSISTING  OF  ONE  OR  TWO  VERIABLES                  XEC  60 

C                          EXAMPLES  RESET  XEC  70 

C                                         RESET  X  XEC  80 

C                                         PRINT  A  XEC  90 

C         Ll=ll-50  FOR  COMMANDS  CONSISTING  OF  ONE  VARIABLE                               XEC  100 

C                          EXAMPLES  ADD  XEC  110 

C                                         MPROP  XEC  120 

C         Ll=51-63  FOR  COMMANDS  CONSISTING  OF  TWO  VARIABLES                             XEC  130 

C                          EXAMPLES  CLOSE  UP  XEC  140 

C                                         M(X'X)  XEC  150 

90        GO  TO  (100,200,300,400,500,600,700,800,900,1000,  XEC  160 

11100,1200,1300,1400,1500,1600,1700,1800,1900,2000,  XEC  170 

22100,2200,2300,2400,2500,2600,2700,2800,2900,3000,  XEC  180 

33100,3200,3300,3400,3500,3600,3700,3800,3900,4000,  XEC  190 

44100,4200,4300,4400,4500,4600,4700,4800,4900,5000,  XEC  200 

55100,5200,5300,5400,5500,5600,5700,5800,5900,6000  XEC  210 

66100,6200,6300) , LI  XEC  220 

C         RESET  XEC  230 

100      CALL  RESET  XEC  240 

GO  TO  9999  XEC  250 

C         PRINT      PRINT    A-F  XEC  260 

200      CALL  PRINTX  XEC  270 

GO  TO  9999  XEC  280 

C         PUNCH  XEC  290 

300      CALL  PUNCH  XEC  300 

GO  TO  9999  XEC  310 

C         APRINT  APRINT    A-F  XEC  320 

400      CALL  APRINT  XEC  330 

GO  TO  9999  XEC  340 

C         READ      READ  A-F  XEC  350 

500      CALL  READX  XEC  360 

GO  TO  9999  XEC  370 

C         ABRIDGE  XEC  380 

600      CALL  ABRIDG  XEC  390 

GO  TO  9999  XEC  400 

C         MPRINT  MPRINT  A-F  XEC  410 

700      CALL  APRINT  XEC  420 

C         NPRINT  NPRINT  A-F  XEC  430 

GO  TO  9999  XEC  440 

800      CALL  PRINTX  XEC  450 

GO  TO  9999  XEC  460 

C         Ll=9    AVAILABLE  XEC  470 

900      RETURN  XEC  480 

C         Ll=10  AVAILABLE  XEC  490 

1000    RETURN  XEC  500 

C         ADD, SUB, MULT,DIV, RAISE, SUBTRACT, DIVIDE, MULTIPLY  XEC  510 

1100    CALL  ARITH  XEC  520 

GO  TO  9999  XEC  530 

C         SIN,ASIN,SIND,ASIND,SINH,ASINH  XEC  540 

C         COS, ACOS,COSD,ACOSD, COSH, ACOSH  XEC  550 

C         TAN , ATAN ,TAND , ATAND ,TANH ,ATANH ,NEGEXP  XEC  560 

C         COT,ACOT,COTD,ACOTD,COTH,ACOTH  XEC  570 

C         ABS , ABSOLUTE , EXP .EXPONENT , LOG ,LOGE , LOGTEN , ANTILOG , SQRT , RAISE  XEC  580 

C         INTEGER , FRACTION, SQUARE  XEC  590 

333 


409-118  OL  -  71  -  22 


1200    CALL  FUNCT  XEC  600 

GO  TO  9999  XEC  610 

C         Ll=13  XEC  620 

1300  GO  TO  (1301,1302,1303,1304,1305,1306,1307,1308,1309,1310,  XEC  630 
11311,1312,1313,1314)  ,L2  XEC  640 

C         GENERATE  XEC  650 

1301  CALL  GENER  XEC  660 
GO  TO  9999  XEC  670 

C         SET  XEC  680 

1302  CALL  SET  XEC  690 
GO  TO  9999  XEC  700 

C         FIXED  XEC  710 

1303  CALL  FIXFLO  XEC  720 
GO  TO  9999  XEC  730 

C         FLOATING  XEC  740 

1304  GO  TO  1303  XEC  750 
C         PLOT  XEC  760 

1305  CALL  PLOT  XEC  770 
GO  TO  9999  XEC  780 

C         PAGE  PLOT  XEC  790 

1306  CALL  PLOT  XEC  800 
GO  TO  9999  XEC  810 

C         Ll=13    L2=7    AVAILABLE  XEC  820 

1307  RETURN  XEC  830 
C         NEW  PAGE  XEC  840 

1308  CALL  PAGE(4)  XEC  850 
GO  TO  9999  XEC  860 

C         SPACE  XEC  870 

1309  CALL  SPACE  XEC  880 
GO  TO  9999  XEC  890 

C         CGS  XEC  900 

1310  CALL  PHYCON(O)  XEC  910 
GO  TO  9999  XEC  920 

C         SI  XEC  930 

1311  CALL  PHYCON(-l)  XEC  940 
GO  TO  9999  XEC  950 

C         FLEXIBLE  XEC  960 

1312  GO  TO  1303  XEC  970 
C         PRINT  NOTE  XEC  980 

1313  CALL  N0TEPR(3)  XEC  990 
GO  TO  9999  XEC1000 

C         ROUND  XEC1010 

1314  CALL  FNEIC  XEC1020 
GO  TO  9999  XEC1030 

C         Ll=14  XEC1040 

1400  GO  TO  (1401, 1402 ,1403, 1404, 1405, 1406 ,1407, 1408, 1409, 1410 ,1411, 1412, XEC1050 
1  1413,1414,1415)  ,L2  XEC1060 

C         BEGIN  XEC1070 

1401  CALL  BEGIN  XEC1080 
GO  TO  9999  XEC1090 

C         SCAN  XEC1100 

1402  GO  TO  1401  XEC1110 
C         REPEAT  EXECUTE  PERFORM  XEC1120 

1403  J=l  XEC1130 
CALL  REPINC(J)  XEC1140 

IF(J)9999,9999,90  XEC1150 

C         Ll=14  L2=  4        AVAILABLE  XEC1160 

1404  RETURN  XEC1170 
C         Ll=14    L2=5      AVAILABLE  XEC1180 
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1405 

RETURN 

XEC1190 

C 

INCREMENT 

XEC1200 

1406 

J=3 

XEC1210 

CALL  REPINC(J) 

XEC1220 

GO  TO  9999 

XEC1230 

C 

Ll=14    L2=7  AVAILABLE 

XEC1240 

1407 

RETURN 

XEC1250 

C 

RESTORE 

XEC1260 

1408 

J=3 

XEC1270 

CALL  REPINC(J) 

XEC1280 

GO  TO  9999 

XEC1290 

C 

IFLT 

XEC1300 

1409 

CALL  IFS 

XEC1310 

GO  TO  9999 

XEC1320 

C 

IFEQ 

XEC1330 

1410 

GO  TO  1409 

XEC1340 

C 

IFGT 

XEC1350 

1411 

GO  TO  1409 

XEC1360 

C 

IFGE 

XEC1370 

1412 

GO  TO  1409 

XEC1380 

C 

IFNE 

XEC1390 

1413 

GO  TO  1409 

XEC1400 

C 

IFLE 

XEC1410 

1414 

GO  TO  1409 

XEC1420 

c 

COMPARE 

XEC1430 

1415 

GO  TO  1409 

XEC1440 

C 

MDEFINE  MZERO  MERASE 

MIDENT 

MDIAGONAL 

XEC1450 

C 

ADEFINE  AZERO  AERASE 

XEC1460 

1500 

CALL  MOP 

XEC1470 

GO  TO  9999 

XEC1480 

C 

MINVERT  INVERT  SOLVE 

XEC1490 

1600 

CALL  INVERT 

XEC1500 

GO  TO  9999 

XEC1510 

C 

Ll=17      NO  L2  VALUES 

ARE  NEEDED 

IN  SUBROUTINES 

XEC1520 

1700 

GO  TO  (1701,1702,1703,1704,1705] 

,L2 

XEC1530 

C 

MMULT  MMULTIPLY 

XEC1540 

1701 

CALL  MMULT 

XEC1550 

GO  TO  9999 

XEC1560 

C 

MRAISE 

XEC1570 

1702 

CALL  MRAISE 

XEC1580 

GO  TO  9999 

XEC1590 

C 

MKRONECKER 

XEC1600 

1703 

CALL  MKRON 

XEC1610 

GO  TO  9999 

XEC1620 

C 

MTRAIN 

XEC1630 

1704 

CALL  MTRIAN 

XEC1640 

GO  TO  9999 

XEC1650 

C 

ME I GEN 

XEC1660 

1705 

CALL  MEIGEN 

XEC1670 

GO  TO  9999 

XEC1680 

1800 

IF  (L2.GT.8)  GO 

TO  1809 

XEC1690 

C 

MADD  MSUB  MTRANS 

SCALAR 

AMULT 

MSUBTRACT 

XEC1700 

C 

AADD  ASUB  ATRANS 

ARAISE 

AD I V I DE 

ASUBTRACT  A MULTIPLY 

XEC1710 

CALL  MATRIX 

XEC1720 

GO  TO  9999 

XEC1730 

C 

ACOALES  AAVERA 

XEC1740 

1809 

CALL  COALES 

XEC1750 

GO  TO  9999 

XEC1760 

C 

NORMLAGUERE  LAGUERE  HERMITE 

LEGENDRE  TCHEBYSHEV  UCHEBYSHEV 

XEC1770 
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c 

POLYFIT    FIT  MORTHO 

XEC2370 

c 

SPOLYFIT  SFIT 

XEC2380 

2200 

CALL  ORTHO 

XEC2390 

GO  TO  9999 

XEC2400 

C 

Ll=23 

XEC2410 

2300 

GO  TO  (2301,2302,2303,2304,2305,2306,2307,2308,2309,2310,2311, 

XEC2420 

12312) ,L2 

XEC2430 

C 

CLOSE  UP 

XEC2440 

2301 

CALL  MISC2 

XEC2450 

GO  TO  9999 

XEC2460 

C 

COUNT 

XEC2470 

2302 

GO  TO  2301 

XEC2480 

C 

SHORTEN 

XEC2490 

2303 

GO  TO  2301 

XEC2500 

C 

EXPAND 

XEC2510 

2304 

GO  TO  2301 

XEC2520 

C 

DUPLICATE 

XEC2530 

2305 

GO  TO  2301 

XEC2540 

C 

MOVE  AMOVE  MMOVE 

XEC2550 

2306 

CALL  MOVE 

XEC2560 

GO  TO  9999 

XEC2570 

C 

Ll=23    L2=7  AVAILABLE 

XEC2580 

2307 

RETURN 

XEC2590 

C 

Ll=23    L2=8  AVAILABLE 

XEC2600 

2308 

RETURN 

XEC2610 

C 

Ll=23    L2=9  AVAILABLE 

XEC2620 

2309 

RETURN 

XEC2630 

C 

PROMOTE 

XEC2640 

2310 

CALL  PDMOTE 

XEC2650 

GO  TO  9999 

XEC2660 

C 

DEMOTE 

XEC2670 

2311 

GO  TO  2310 

XEC2680 

C 

DIMENSION  DIM 

XEC2690 

2312 

CALL  DIMENS 

XEC2700 

GO  TO  9999 

XEC2710 

C 

Ll=24 

XEC2720 

2400 

GO  TO  (2401,2402,2403,2404,2405,2406,2407,2408,2409,2410, 

XEC2730 

1  2411,2412,2413,2414,2415) ,L2 

XEC2740 

C 

STATIS 

XEC2750 

2401 

CALL  STATIS 

XEC2760 

GO  TO  9999 
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GO  TO  9999 

XEC2850 

C 
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c 

Ll=43 

XEC3550 

c 

Ll=44 

XEC3560 
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RETURN 

XEC3570 

3400 

RETURN 

XEC3580 

3500 

RETURN 

XEC3590 

3600 

RETURN 

XEC3600 

3700 

RETURN 

XEC3610 
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RETURN 

XEC3620 
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RETURN 

XEC3630 
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RETURN 
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RETURN 
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RETURN 
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RETURN 

XEC3670 
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RETURN 
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C*****  THE  FOLLOWING  CARDS  ARE  NEEDED  ONLY    FOR  TAPE  OPERATIONS 
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THE  STATEMENTS    4500  -5000    WERE      RETURN  STATEMENTS 

XEC3700 
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READ  TAPE 

XEC3710 
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CALL  TAP0P2 

XEC3720 

GO  TO  9999 

XEC3730 
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CREAD  TAPE 

XEC3740 

4600 

GO  TO  4500 

XEC3750 
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WRITE  TAPE 

XEC3760 

4700 

GO  TO  4500 

XEC3770 
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SET  TAPE 
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GO  TO  4500 
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C 

CSET  TAPE 

XEC3800 
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GO  TO  4500 
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CALL  DUMMY A 
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XEC4010 
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CALL  DUMMYB 

XEC4030 

GO  TO  9999 

XEC4040 
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5404 

CALL  DUMMYC 

XEC4060 

GO  TO  9999 

XEC4070 
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CALL  DUMMYD 
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GO  TO  9999 

XEC4100 

C 

DUMMY  E 
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CALL  DUMMYE 

XEC4120 

GO  TO  9999 
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DUMMY  F 
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SUBROUTINE  XFORMT  XFO  10 

C         VERSION    5.00         XFORMT         5/15/70  XFO  20 
COMMON  /BLOCKA/  MODE , M, KARD (83 ) (KARG , ARG , ARG2 , NEWCD (80 ) ,KRDEND        XFO  30 

C  XFO  40 

C         LOOK  FOR  LETTER  A-F  FOLLOWED  BY  NON-ALPHANUMERIC  CHARACTER  XFO  50 

C         A  $  =  46  STOPS  THE  SCAN  XFO  60 

10        M=M+1  XFO  70 

IF  (KARD(M) .LT.IO.OR.KARD(M) .GT.15)  IF (KARD (M)-46)     10,20,10  XFO  75 

IF  (KARD (M+l ) .LE .35)  GO  TO  20  XFO  80 

C         CALL  PREPAK  TO  STORE  FORMAT  XFO  90 

C         IF  IND=0    FORMAT  IS  O.K.  AND  STORED  XFO  100 

C         IF  IND=1    NUMBER  OF     (    DOES  NOT  EQUAL  THE  NUMBER  OF  )  XFO  110 

C  XFO  120 

CALL  PREPAK  (1 , IND , IR , IR , IR)  XFO  130 

IF  (IND.EQ.O)  RETURN  XFO  140 

20        CALL  ERROR  (205)  XFO  150 

RETURN  XFO  160 

END  XFO  170 


SUBROUTINE  XHEAD  XHE  10 

C  VERSION  5.00  XHEAD  5/15/70  XHE  20 
COMMON  /BLOCKA/  MODE, M,KARD(83) ,KARG, ARG, ARG2 , NEWCD (80) .KRDEND  XHE  30 
COMMON  /BLOCKD /  I ARGS ( 100 ) , KIND ( 100 ) , ARGTAB ( 100 ) , NRMAX , NROW, NCOL , NXHE  40 

1ARGS ,VWXYZ (8 ) ,NERROR  XHE  50 

COMMON  /ABCDEF/  L(48)  XHE  60 

GO  TO  20  XHE  70 

10        M=M+1  XHE  80 

20        IF  (KARD (M) .GE . 10 )  IF  (KARD(M)-46)  10,30,10  XHE  85 

CALL  AARGS  XHE  90 

I=ARG  XHE  100 

IF  (KARG.EQ.O.AND.I .GT.O.AND.I .LE.NCOL)  GO  TO  60  XHE  110 

30        CALL  ERROR  (204)  XHE  120 

RETURN  XHE  130 

50        M=M+1  XHE  140 

60        IF   (KARD (M) .NE .36)   IF   (KARD(M)-46)     50,30,50  XHE  145 

C  XHE  150 
C         SLASH  FOUND.  PICK  UP  NEXT  12  CHARACTERS     IN    FORMAT  Al  AND  PACK      XHE  160 

C  XHE  170 

80        CALL  PREPAK  (2 , IND , I , IR , IR)  XHE  230 

RETURN  XHE  240 

END  XHE  250 
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>  J.  u 

C  A 

D  U 

tT|  r  (T      l\     1   /  AK  V 
i 1 Lt ( 1 , J ) =L (45 ; 

XOM 

A  \J  1*1 

DO  60  1=1,6 

XOM 

J  J  u 

L  A 

60 

IFMTX(I)=IFMTS(I) 

XOM 

I0SWT=0 

XOM 

350 

IHCNT=0 

XOM 

CALL  PREPAK(3,IND,IND,IND,IND) 

XOM 

M0DE=1 

XOM 

400 

NRMAX=0 

XOM 

410 

NR0W=201 

XOM 

420 

"T  b  w 

NC0L=62 

XOM 

430 

KRDEND=80 

XOM 

440 

LLIST=3 

XOM 

4^0 

NERR0R=0 

XOM 

4A0 

NSTMT=0 

XOM 

470 

NSTMTH=0 

XOM 

480 

NC0M=1 

XOM 

4Q0 

LC0M=2000 

XOM 

500 

■P  w  V 

LEVEL=0 

XOM 

505 
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IOVFL=0 

XOM 

510 

NPAGE=0 

XOM 

520 

NRCC=NRC+100 

XOM 

530 

00  90  I=1,NRCC 

XOM 

540 

RC(I)=0. 

XOM 

550 

NERR=0 

XOM 

560 

NERC0N=100 

XOM 

570 

ISWERR=0 

XOM 

580 

DO    100  1=1,8 

XOM 

584 

VWXYZ(I)=0.0 

XOM 

586 

JPC=-1 

XOM 

588 

CALL  NOTEPR  (0) 

XOM 

600 

RETURN 

XOM 

605 

END 

XOM 

610 
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c 
c 
c 
c 
c 
c 
c 
c 


c 
c 
c 


10 


20 
30 


C 

c 
c 

40 


50 


SUBROUTINE  XPND  (T  ,K  ,Y  ,KND) 

VERSION    5.00         XPND  5/15/70 

COMMON  /BLOCRC/  NRC  ,RC (12600) 

COMMON  /BLOCKD /  IARGS(IOO) ,KIND(100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL 
1ARGS,VWXYZ(8) ,NERROR 
DIMENSION  ARGS(IOO) 
EQUIVALENCE  (ARGS ( 1 ), RC ( 12501 ) ) 
DIMENSION  T(2) 

THIS  SUBROUTINE  TAKES  A  "STATEMENT"  REFERENCE  AS  STORED 
AND  EXPANDS  IT  INTO  THE  PROPER  ARGUMENT  WITH  CHECKING. 

K  IS  RETURNED  0  IF  ARG  IN  STATEMENT  IS  ONE  WORD  LONG 
K  IS  RETURNED  1  IF  ARG  IN  STATEMENT  IS  TWO  WORDS  LONG. 
K  IS  RETURNED  -(  ERROR  NUMBER  )  IF  ERROR  OCCURS. 


IT— T(l) 
IF  (IT.LT 


16)  GO  TO  40 


"ROW,  COL"  ENTRY 
IT=IT-8208 

IF  (IT.GT.O.AND.IT.LE.NROW)  GO  TO  10 

K=-16 

GO  TO  20 

IARGS(100)=ABS(T(2) )-8192. 

KIND(100)=0 

CALL  ADRESS  (100, J) 

IF  (J.NE.O)  GO  TO  30 

K=-ll 

RETURN 

J=J+IT 

KND=0 

IF  (T(2).LT 
Y=RC(J-1) 
K=l 

GO  TO  20 


0.)  KND=1 


NRMAX,  V,  W,  X,  Y,  Z,  REFERENCE 

IU=IT/2 

KND=IT-2*IU 

K=0 

IF  (IU.LE.l)  GO  TO  50 

Y=VWXYZ(IU-2) 

GO  TO  20 

Y=NRMAX 

GO  TO  20 

END 


XPN 
XPN 
XPN 
NXPN 
XPN 
XPN 
XPN 
XPN 
XPN 


10 
20 
30 
40 
50 
60 
70 
80 
90 


XPN  100 
XPN  110 
XPN  120 
XPN  130 
XPN  140 
XPN  150 
XPN  160 
XPN  170 
XPN  180 
XPN  190 
XPN  200 
XPN  210 
XPN  220 
XPN  230 
XPN  240 
XPN  250 
XPN  260 
XPN  270 
XPN  280 
XPN  290 
XPN  300 
XPN  310 
XPN  320 
XPN  330 
XPN  340 
XPN  350 
XPN  360 
XPN  370 
XPN  380 
XPN  390 
XPN  400 
XPN  410 
XPN  420 
XPN  430 
XPN  440 
XPN  450 
XPN  460 
XPN  470 
XPN  480 
XPN  490 
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SUBROUTINE  XSTOP 

XST 

10 

c 

VERSION    5.00          XSTOP  5/15/70 

XST 

20 

COMMON  /BLOCKC/  KIO , I NUN  IT , ISCRAT ,KBDOUT ,KRDKNT ,LLIST 

XST 

30 

COMMON  /BLOCRC/  NRC , RC ( 12600 ) 

XST 

40 

COMMON  /BLOCKD /  IARGS(IOO) , KIND (100) , ARGTAB ( 100 ) ,NRMAX ,NROW, NCOL , NXST 

50 

1ARGS,VWXYZ(8) ,NERROR 

XST 

60 

DIMENSION  ARGS(IOO) 

XST 

70 

EQUIVALENCE  (ARGS (1) ,RC (12501) ) 

XST 

80 

COMMON/HEADER /NOCARD (80 ) , ITLE (60,6) ,LNCNT , IPRINT ,NPAGE , IPUNCH 

XST 

90 

COMMON  /SCRAT/  NS ,NS2 , A  (13500 ) 

XST 

110 

DIMENSION  ITEMP(84) 

XST 

120 

EQUIVALENCE  ( ITEMP ( 1 ) ,A (1 ) ) 

XST 

130 

DATA  IZ,IP,N0,K0MMA/1HZ,1H+,1H0,1H, / 

XST 

140 

c 

XST 

150 

c 

THIS  ROUTINE  REWINDS  THE  SCRATCH 

UNIT 

AND 

PRINTS 

IT. 

XST 

160 

c 

XST 

170 

REWIND  ISCRAT 

XST 

180 

LLIST=0 

XST 

190 

IF  (NERROR.EQ.O)  LLIST=3 

XST 

200 

10 

CALL  PAGE  (0) 

XST 

210 

WRITE  (IPRINT, 90) 

XST 

220 

DO  40  J=l,50 

XST 

230 

READ  (ISCRAT, 100)  ITEMP 

XST 

240 

IF  (ITEMP(l) .EQ.IZ)  GO  TO  50 

XST 

250 

IF  (ITEMP(l) .EQ.IP)  GO  TO  30 

XST 

260 

IF  (ITEMP (1) .EQ.KOMMA)  GO  TO  20 

XST 

270 

WRITE  (IPRINT, 110)  ITEMP 

XST 

280 

GO  TO  40 

XST 

290 

20 

LLIST=3 

XST 

300 

IF  (ITEMP (2) .EQ .NO .AND . NERROR . EQ . 

0)  LLIST 

=0 

XST 

310 

GO  TO  40 

XST 

320 

30 

WRITE  (IPRINT, 120)   ( ITEMP ( I ) , 1=2 , 

84) 

XST 

330 

40 

CONTINUE 

XST 

340 

GO  TO  10 

XST 

350 

50 

REWIND  ISCRAT 

XST 

360 

IF  (NERROR-1 )  80,60,70 

XST 

370 

60 

WRITE  (IPRINT,130) 

XST 

380 

GO  TO  80 

XST 

390 

70 

WRITE  (IPRINT, 140)  NERROR 

XST 

400 

80 

LLIST=3 

XST 

410 

WRITE  (IPRINT, 150) 

XST 

420 

WRITE  (IPRINT, 160) 

XST 

430 

RETURN 

XST 

440 

C 

XST 

450 

90 

FORMAT  (//19X,39H  LIST  OF  COMMANDS,  DATA 

AND  DIAGNOSTICS//) 

XST 

460 

100 

FORMAT  (84A1) 

XST 

470 

110 

FORMAT  (20X.84A1) 

XST 

480 

120 

FORMAT  (18X,3A1,3X,80A1) 

XST 

490 

130 

FORMAT  (///40X,20H0NLY  ONE  FATAL 

ERROR) 

XST 

500 

140 

FORMAT  (///40X,I4,7H  ERRORS) 

XST 

510 

150 

F0RMAT(1H0/33X,95H  NATIONAL  BUREAU  OF 

STANDARDS, 

WASHINGTON,  D. 

C.XST 

520 

1    20234,  OMNI TAB  II  VERSION  5.00 

MAY 

15, 

1970  ) 

XST 

530 

160 

FORMAT (1H1 ) 

XST 

690 

END 

XST 

700 
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8.  Appendix  —  OMNIT     Flow  Chart 


Flow  Chart  Notes 

(1)  The  flow  chart  of  the  OMNIT  subprogram  was 
generated  by  the  FLOGEN  program  on  the  UNIVAC 
1108  and  drawn  by  the  CAL-COMP  plotter;  see 
CAL-COMP  [1968]. 

(2)  When  the  flow  of  the  diagram  is  broken,  an 
arrow  points  to  a  box  with  two  symbols.  The  top 
number  refers  to  the  page  and  the  bottom  symbol 
is  the  entry  point.  At  each  entry  arrow,  the  number 
inside  the  box  indicates  the  page  from  which  the 
flow  comes  and  the  symbol  outside  is  the  entry 
position. 

(3)  The  INPUT  subprogram  reads  an  OMNITAB 
instruction  and  stores  the  information  in  the  array 
KARD.  Each  character  is  stored  in  one  location 
starting  with  the  character  of  the  first  column  in 
KARD(3).  See  page  2  of  the  flow  chart. 

(4)  The  subprogram  NNAME  takes  the  first  six 
or  less  characters  of  the  first  nonnumeric  word  and 
converts  them  into  two  numbers  by  combining  the 
values  assigned  to  each  letter.  (See  NNAME  for 
the  values  assigned  to  each  letter.)  The  numbers  are 


stored  in  NAME(l)  and  NAME(2).  See  page  5 
of  the  flow  chart. 

(5)  Pages  5  through  11  of  the  flow  chart  check  to 
see  if  the  OMNITAB  command  is  one  of  the  fol- 
lowing: OMNITAB,  FINISH,  FORMAT,  NOTE, 
HEAD,  TITLE  or  STOP. 

(6)  The  subprogram  EXPAND  converts  the  values 
in  ARGTAB,  described  on  page  18  of  the  flow  chart, 
to  floating-point  numbers  and  stores  them  in  either 
the  array  IARGS  or  the  array  ARGS,  depending 
upon  whether  an  argument  is  an  integer  or  a  floating- 
point number.  Also,  EXPAND  sets  KIND(I)  =  0,  if 
an  argument  is  an  integer,  and  sets  KIND(I)=1,  if 
an  argument  is  a  floating-point  number;  see  pages 
19  and  22  of  the  flow  chart. 

(7)  A  table  look-up  is  done  by  the  subprogram 
LOOKUP  using  NAME(l),  NAME(2)  and  some- 
times NAME(3)  and  NAME(4).  Also,  a  set  of  unique 
numbers  are  assigned  to  the  variables  Ll  and  L2. 
If  Ll=0,  no  command  was  found;  see  page  20  of 
the  flow  chart. 

(8)  If  a  command  is  found,  the  subprogram 
XECUTE  is  called  to  execute  the  instruction; 
see  page  22  of  the  flow  chart. 
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SUBROUTINE  0MNIT 


C  VERSION     5-00  OMNIT  5/15/70 

C  *  *  *  * *  * * *  *  *  *  *  * * *   THIS    IS   THE  MAIN   OMNITAB  ROUTINE  ****************x 


COMMON  /BLOCKA/  MODE  .  M  ,  KflRD ( 83  )  .  KRRG  ,  HRG , ARG2 , NEWCD ( 80 ) , KRDEND 

COMMON  /BLOCKS/  NSTMT , NSTMTX , NSTMTH , NCOM . LC0M  .  I OVFL  ,  COM ( 2000  ) 

COMMON  /BLOCKC/  K I  0  .  I  NUN  I T  .  I SCRAT . KBDOUT , KRDKNT . LL I  ST 

COMMON  /BLGCRC/  NRC.RCC 12600) 


COMMON  /BLOCKD/  IARGS(1OO).KIND(1OO).ARGTAB(1OO),NRMAX.NROW.NC0L,N 
RRGS  ,  VWXYZ( 8 )  ,  NERROR 


DIMENSION   ARGS( 100 ) 
EQUIVALENCE   ( ARGS (  1  )  ,RC(  12501  J  ) 
COMMON   /BLOCKE/   NAME ( 4  )  .  L 1  .  L2  .  I  SRFLG 

CQMM0N/HEADER/N0CARD(8O),ITLE(6O.6),LNCNT,IPRINT , NPflGE . I  PUNCH 


THE     FOLLOWING     CARDS   ARE     NEDDED     ONLY     FOR   THPE  OPERATIONS 


COMMON   /TAPE/   NAME4 ( 2  )  ,  NTPCT  ,  I PUNCP  ,  I  NUN  I  P  ,  L  1  TP 


1 


DATA   I  BLANK/ 1 H  / , LETSGO/- 1 / 


C  THIS    IS   THE  MAIN   0MNITAB  PROGRAM 

C  SUBROUTINES   COLLED   BY   THIS  PROGRAM . . 

C  SETUP. INPUT. ERROR. STMT, NNAME.  A ARGS. ASTER. SETQ.READQ. STORE. XECUTE 

C  flERR.XOMNIT.XFORMT, LOOKUP 

C  MOD   =    1      INTERPRETIVE  MODE 

C  =2     DATA  MODE   ( READ  SET) 

C  =3     STORAGE  MODE   (BETWEEN  BEGIN  AND  FINISH) 

C  =4      IMPLIED  STORAGE   MODE    (STATEMENT   NUMBER  GIVEN) 


3 


C  0=0.1=1.   ETC  .  .   9  =     9  .   A  =   1 0  . 

C  .   =  37 ,   -  =  38 ,   +  =  39  .   *  =   40.    (    =  41 

C  BLANK   =   44.    =   =   45.   $   AND  OTHERS   =  46 


=   11,   ETC ,   Z=  35  .   /  =  36 
=  42 .    .   =  43 


4 

7 

15 

T20J 

]2\1 

no 

L6.J 

LlsJ 

l_20j 

21 

L22.J 

CONT  .   ON  PG 


PG   1  OF 


22 
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"FT 


Rl 


-t>i 


NSTMTrNSTMT+l 0~~] 

1 

r 

n2 

MODE^l 

<i — 

NRME(  1  )-0 


NRME  C 2  1:0 
NflMEt  3)=0 
NRME(  4  1=0 
NRRGS^O 

J:0 

 i_ 


CHECK  FOR  RCCUMULHTEO  ERRORS  DURING  LAST  EXECUTED  EOMMRND 


3 


CRLL  rerr"  Toi" 


20 


A3 


±1. 


SL 


fCRLL  INPUT 


SCANNING  BEGINS  WITH  THE  THIRD  CHARACTER  .  THE  FIRST  TWO  ARE  DUMMY 
TO  KEEP  THE  PROGRAM  OUT  OF  TROUBLE  .  SCANNING  TERMINATES  WITH  A  $ 
A   $  HAS   BEEN  PLANTED    IN   THE    ( KRDEND+ 1  )  -TH  POSITION. 


V\-2 

~~T~__ 
|R4 


30 


Tm-m+ i 

|_K  z  K  A  R  D  (  M  ) 

V 


V 

CONT.    ON  PG 


PG  2  OF 


22 


345 


[~GQ  TO"  60 


C  fl  NUMBER    IS   THE   FIRST   ALPHANUMERIC  CHARACTER   ENCOUNTERED  .    ERROR  IF 

C  IN   MODE  3 


CALL  OUTPUT" 


n5 


_35  £    

[£ALL  ER_ROR  (2)^| 

HZ 21 


f 


V 

CONT.    ON  PG  4 


PG  3     OF  22 


409-118  OL  -  71  -  23 


349 


GO  TO  20  ">H> 


2_ 
A3 


350 


r            IF   AN    II  1  FGAI     STATFMFNT   NllMRFR   WAS   FOUND     KARG   -    1    (KARG   -   ("1  IF 

u                  11      n  in     i  i_  i_  l_     ri  i       «j  i  n  i  i  i  i  l.  i  ■«  i      i  vu  I  i  lj  i_  I  \     n  n  u     i   u  u  in  u  »     i  \  n  i  \  u     —      i      i  i\ni\u     —     u     i  i 

C  LEGAL) 

4 

i  i> 

R9 

MODE  =  4 


3: 


M    IS   POINTING  AT   THE   FIRST   LETTER   QN   THE   CARD.    ASSEMBLE  NAME 


BO 


i  • 


SO  <7 


CALL   NNAME   ( N  AME  ( 1 ) ) 


"EL~ 


c 

CHECK   THE  FIRST 

NAME   FOR  SPECIAL 

NAMES  •  .  . 

c 

OMNITAB.  FORMAT 

NOTE.  FOOTNOTE. 

HEAD  .  T I TLE 

c 

OMN I  TAB 

IF   NOT   THE   FIRST   OMNITAB   CARD.    NRITE   EOF  RECORD 


WRITE   [  ISCRAT  .390  "]' 


CONT  .    ON  PG  6 


PG  5     OF  22 


351 


 xz_ 

MODE; 


^7  r 
GO   TO  4Q^>-4>- 


R6 


FORMRT 


v 


v 

CONT.   ON  PG 


PG  6  OF 


22 


352 


GQ  TO  10 


AO 


CONT  .   ON  PG  8 


PG  7     OF  22 


353 


GO  TO   100  ~>H>-§ 


B8 


fCRLL  PRGE  (0 


tz 

f3- 


_2 


[~vTR T  TE~"  C  I  PR  I  NT  ,400  )    (  N  E  W  CD (  1-2  )  ,  I~=M  ,82  )"j 

A. 


LNCNT-LNCNT  +  l" " 

. — A  ^ 

I  GO  TO  80  J>\ 


B5 


CONT.   ON  PG  9 


354 


B7 

95 


CALL   NOTEPR   ( K  I 


T 


£ 


GO  TO  80 


B5 


[GO  TO  30 


TITLES 


TITLEX  =  TITLE5,   TITLEY  =  TITLE6 


C           CHECK   NAME  TITLE 

0  

PG  9     OF  22 


355 


9 


GO  TO  120~^> 


K  =  6 


GO  TO  130~~^>£>- 


1  1 


CI 


|0- 


120  <7  

K  =  KfiRD( M  ) 


GO  TO  130~^>t>- 


 V. 


fCRLL" ERROR  (209) 


±1 


CONT  .   ON  PG  11 


PG   10  OF  22 


356 


10 


10 


10 


K=l 


-O 


CI 

130  <7 


MM=MIN0(  M  +  59  .81 


<  DO   140   1=1 ,60  > 


140  ± 


I TLE ( I . K IrlBLHNK 


1  =  1 


DO   150  MRr.ri.MM 


I TLE  C  I  .  K JrNEWCDt  MR-1  ) 


150  _£ 


=  IM] 


5 


GO  TO  80 


7_ 
B5 


C  STOP 

9 

1  10 

C2 

IF    ( NAME  (  1  )  .NE.14406.0R.NAME(2)  .NE  .  11664 


GO  TO   1 7  0  ^^>- 


1  2 


C3 


i<3- 


7 


I  WRITE   (  ISCRAT  ,390  ) 

 £__ 


CALL  XSTOP 


stop"] 


CONT  .    ON  PG  12 


PG   1 1   OF  22 


357 


C  M    IS  POINTING  fl T   THE   FIRST   NQN-LETTER   AFTER   NCI  ME  •   LOOK  FOR 

C  POSSIBLE  NAME  QUALIFIER  OR  ARGUMENTS  OR  END  OF  CARD. 


GO_  TO    1 90    ^  H>- 


.  2  . 

GO   TO   170  J>- 


CONT.   ON  PG  13 

PG   12  OF 


358 


C           fl  LETTER  FOUND.   ASSEMBLE  SECOND  NRME   (COMMANCF  QUALIFIER). 

12 

l  > 

C4 

175  V 


CALL   NNRHF  INRMEO 


3 


C  CHECK  SPECIAL   CASE   OF   NAMES   M1\HX'),   M(Y'flX).    M  C  X  X    ),  M(X'X 

C  SKIP   ONE   CHARACTER    (    )    IF  FIRST   NAME   =(M  ) 

C  THE  FOLLOWING  CARD   IS       NEEDED  ONLY  FOR  TAPE  OPERATIONS 

C  IS  NAME ( 3  )    EQUAL   TO   TAP  AND  NAME ( 4  )  =E 


GO  TO  180~^>- 


r  } 


CALL  TAPOP 


1 


3 


GO  TO  190 


1  4 


C6 


CONT.    ON  PG  14 


PG   13  OF  22 


359 


SCRN  FOR  ARGUMENTS  AND  END  0F  CARD 


C5 


-o 


185  ,  i 


M  =  3 


1  3 


1  2 


1  3 


C6 


-oo- 


C6 


15 


190  i 


J  =  J+  1 


00    10  2TTJ 


f3- 


C7 


19 


V 


200  £ 


M=n  + 1 


o- 


C8 


17 


18 


210  K7 


C  NUMBER   FOUND  .    CONVERT   ARGUMENT.    IF   KARG  RETURNED   =   0.    NUMBER  IS 

C  INTEGER. IF  KARG  =   1.   NUMBER   IS  FLOATING  POINT.    IF  KARG  =   -1,  ERROR 


CALL  AARGS 


HI 


f 


3 


V 


CONT.    ON  PG 


15 


PG   14  OF 


22 


360 


0 


C9 


220  <7  

HRGTHHf  J  )=0  • 

J  =  J+  1 

,  ir  ^ 

GO  TO  240 


C  ARGUMENT    IS  AN    INTEGER.   ADO   A   BIAS  OF   8192   THEN   CHECK   THAT    IT  IS 

C  .GT.  0 


-O 


230  <7 
ARG= ARG+8 1 92 ■ 


T 


 2  

GO  TO  240 


f3- 


 2  

CALL  ERROR  (  1  8 
 1 


i 


21 


GO   TO  10~^>4>- 


AO 


240  ft 


ARGT AB ( J ) -ARG 

250  S 

^  rn 

UU  |7 

7 

NARGS=NARGS+ 1 

GO   TO  190~~^>4> 


CQNT  .    ON  PG  16 

PG   15  OF 


361 


C  RSTERISK  FOUND.  CONVERT 

C  IF  BRACKETED  BY  SINGLE  ASTERISKS  .   QUANTITY   IS   T 0  BE  USED  AS  A 

C  FLOATING  POINT  ARGUMENT  .  I F  BRACKETED  BY  DOUBLE  ASTERISKS.  QUANTITY 

C  IS   TO  BE   TRUNCATED  AND  USED  AS  AN   INTEGER  ARGUMENT . 


GO  TO  260~^>- 


iO- 


|  KARG-O 


M  =  M+  1 


O- 


260,  ± 


MS  =  M 


CALL  ASTER 


c 
c 
c 
c 
c 
c 
c 
c 


THE   TERMINAL   ASTERISK(S)    HAVE   BEEN   CHECKED   TO   BE   THE   SAME   AS  THE 


INT  I TAL  SET  (IF  NO  ERROR 
AFTER   THE   LAST  ASTERISK. 


AND   M    IS  POINTING  AT   THE   FIRST  CHARACTER 


KARG  RETURNED  AS 


1  =  ERROR  FOUND 

2  =  FLOATING  POINT   CONSTANT,  Z-B-  *PI* 

3  =  INTEGER  NAMED  VARIABLE.  Z-B.  **NRMAX** 

4  =  FL.   PT.   NAMED  VARIABLE.  Z-B.  *NRMAX  * 

5  =  INTEGER  ROW-COLUMN  .  Z-B-  **3.40** 


C 
C 

c 
c 
c 
c 
c 
c 


A  STRING 
EXAMPLE  . 
ERASE  1 
ERASE  1 
PRINT  1 
PRINT  1 


OF 

2  3  4 
*  *  *  4 
20  19 
20  *> 


6  =   FL  •    PT  .   ROW-COLUMN . 

7  =  STRING  OF  ASTERISKS 
THREE   OR   MORE   ASTERISKS  IMPL 


Z  -B 
Z  .B 

ES  -THRU- 


*  1  ,  2* 


1  2 

12  * 
18  17 
*   1  4 


3  14 


15 
6  . 
15 


16 
20 
1  4 


20  IS   EQUIVALENT  TO 

IS  EQUIVALENT  TO 


CONT  .   0N  PG 


17 


PG   16  OF 


22 


362 


-<C  GG  TQ   (270,220.280.280.290,290.300).  KRRG~ 


15 
C9 


V      K?      V  K7 


18 


D2 


270.  ft 


M  =  MS 
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RRGTRB (  J  )  =  -2  .*RRG-FL0RT(  KflRG-3 


GO  TO  250 
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290  <7 


RRGTRB (  J  )=-(  RRG+8208  .  )"" 


HRG2=-RRG2 


— 2— 1 
J  =  J+1 


RRGTRB ( J 1-RRG2 
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CALL  ERROR  (211 


T 


GO  TQ  210  j>H> 


1  4 


C8 


310  ^ 


ARGT A8 ( J 


GO  TO   1 90  ^>H> 


C6 


C  RRGTflB  SETUP 

C  IF  ENTRY    .GT.    0.    IT    IS   AN    INTEGER   CONSTANT    (Z-B.    COLUMN   NUNBER  ) 

C  TO  WHICH  A  BIAS  OF  8192  HAS  BEEN  ADDED  .     THIS   IS   TO  SAY   THAT  A 

C  NEGATIVE   INTEGER  ARGUMENT  MAY  NOT  BE  EXPLICITLY  GIVEN  OR  MODIFIED 

C  TO  BE  LESS   THAT   -8191  . 

C  IF  ENTRY    -EQ.O.    THE   NEXT   ENTRY    IS  A   FLOATING  POINT   CONSTANT  . 

C  IF  ENTRY    .LT.   0.   ARGUMENT   IS  A  VARIABLE  •   SET  SIGN  POSITIVE  AND.. 

C  IF   ENTRY    .LT.    16.    IT    IS   A   NAMED   VARIABLE   REFERENCE  NUMBER 


2,3     NRMflX  6.7         V  10.11  X 

8.9         W  12.13  Y 

14.15  Z 

V.W.X.Y.Z.  ARE  FOR  PROGRAMMING  CONVENIENCE  ONLY  AND  DO  NO  f 
AFFECT  THE  OPERATION  OF  OMNITAB 

IF   ENTRY    IS   EVEN.    CURRENT   VALUE   TQ   BE   TRUNCATED   AND  USED 
AS  AN   INTEGER  ARGUMENT. 

IF   ENTRY   IS  ODD.   THE  CURRENT   VALUE   IS  TO  BE  USED  AS'A 


5 


FLOATING  POINT   ARGUMENT . 
IF   ENTRY    -GT.    16,    IT    IS   A   WORKSHEET   REFERENCE    (ROW. COLUMN)  TO 
WHICH  A  BIAS  OF  8192.   HAS  BEEN  ADDED  . 
ENTRY   -  8208  =  ROW  NUMBER 

ABS ( NEXT   ENTRY)    =   COLUMN   NUMBER   TO   WHICH   A   BIAS   OF  8192. 

HAS  BEEN  ADDED. 
IF  NEXT  ENTRY   IS  NEGATIVE.   WORKSHEET  CONTENTS  ARE   TO  BE 
USED   AS   A   FLOATING  POINT   CONSTANT.      IF   +  ,    WORKSHEET  VALUE 


TQ  BE   TRUNCATED  AND  USED  AS  AN   INTEGER  ARGUMENT 
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GO  TO  200"""^>H> 


C         THE   TERMINATION   OF   CARD   FOUND   (    $   ENCOUNTERED  ) 


C  IN   INPUT  MODE  AND  NO  POSSIBLE  NAME.   RETURN  TO  SET  OR  READ  ROUTINE 
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1  CALL   EXPAND   t  J  .  ARGTAB ) 


] : 


CQNT.   ON   PG  20 
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GQ   TO  340 
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CALL  SETQ 


T 


£ 


GO   TO  10~^>H> 
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340  <7 


CALL  READQ 


1 


£ 


3 


GO  TO   10  >n> 


1 


AO 


LOOK  UP  NAME  (AND  POSSIBLE  QUALIFIER)  IN  DICTIONARY.  RETURN 
COORDINATES   OF   ENTRY.    IF   LI    =   0.    NAME   NOT  FOUND 


GO  TO  330~^>D>1 
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CALL  ERROR   (  1  ) 
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£ 
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GO  TO  10^>>-O 


no 


c 

NRliE  FOUND 

c 

THE     FOLLOWING  CARDS 

ARE 

NEDDED     ONLY     FOR   TAPE  OPERATIONS 

c 

STATEMENT  WAS     220  IF 

MODE 

■EQ.2)  M0DE=1 

f3- 


2 


CALL   ST 0 R E   ( J  ) 


£ 


±i 


GO  TO  10 
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MODE:: 1 
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INUNITrlNUNIP 
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21 

i  0 

El 
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CALL   EXPAND  (J.flRGTAB) 


CALL  XECUTE 


GO   TO   10  ">-i> 


390  

FORMAT   (  1HZ  .83X  ) 


400  \ 

7 

FORMAT  ( 

IX  .  80R 1  ) 

END 
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